(define (solve-alphametic lst)
(let    ((ersten  (finderste lst)))
(let    ((letters (union(accumulate word (neubind (car lst)(cadr lst)(caddr lst)))))) 
(let    ((birl    (key (car lst) (cadr lst) (caddr lst))))
     (mergesort (diener letters (car lst) (cadr lst) (caddr lst) ersten birl)))))) 


(define (diener letters wrd1 wrd2 wrd3 ersten birl)
(if (> (count letters) 10) `()
          (kern letters `1234567890 `() 1 wrd1 wrd2 wrd3 ersten birl)))  

(define (kern letters zahlen coz n wrd1 wrd2 wrd3 ersten birl) 
 (if     (> n (count zahlen)) `()
  (if     (and (member? (first letters) ersten) (= (item n zahlen) 0))
   (kern letters zahlen coz (+ n 1) wrd1 wrd2 wrd3 ersten birl)
   (if     (necessity (cons(list (first letters)(item n zahlen)) coz)
                       birl wrd1 wrd2 wrd3)
    (if (empty? (bf letters))
     (if (control1 wrd1 wrd2 wrd3 (cons(list(first letters)(item n zahlen)) coz))
           (cons(list(first letters)(item n zahlen)) coz) `())
     (let    ((kume (kern (bf letters) (rmo (item n zahlen) zahlen)
                          (cons (list (first letters)(item n zahlen)) coz)
                          1 wrd1 wrd2 wrd3 ersten birl)))
      (cond   ((not kume)(kern letters zahlen coz (+ n 1) wrd1 wrd2 wrd3 ersten birl))
             (else kume))))
    (kern letters zahlen coz (+ n 1) wrd1 wrd2 wrd3 ersten birl))))) 

(define (finderste lst)
(word (first (caddr lst)) (first (cadr lst)) (first (car lst))))

(define (union wrd)
(cond   ((empty? (bf wrd)) wrd)
        ((member? (last wrd) (bl wrd)) (union (bl wrd)))
        (else (word (union (bl wrd)) (last wrd))))) 

(define (ls x wrd)        ;takes last n element
(let    ((a (count wrd))) 
(cond   ((> x a) wrd)
        (else ((repeated bf (- a x)) wrd)))))

(define (neubind wrd1 wrd2 wrd3) ;gives the list of letters for each degree 
(cond   ((and (empty? wrd1) 
              (empty? wrd2) 
              (empty? wrd3)) `()) 
        (else (append (list (word (nlas wrd1)(nlas wrd2)(nlas wrd3)))
                      (neubind (nbl wrd1)(nbl wrd2)(nbl wrd3))))))

(define (nlas wrd)         ;a special last for neubind
(cond   ((empty? wrd) "")
        (else (last wrd))))

(define (nbl wrd)          ;a special butlast for neubind 
(cond   ((empty? wrd) "")
        (else (bl wrd))))

;removes all the word from the other one
(define (srmo wrd1 wrd2)
(if (or (empty? wrd1)(empty? wrd2)) wrd2 (rmo (first wrd1) (srmo (bf wrd1) wrd2))))

(define (rmo x wrd)
 (if     (empty? wrd) ""
  (if    (equal? x (first wrd)) (bf wrd)
                                (word (first wrd) (rmo x (bf wrd))))))

;removes all the elements of a word from the list
(define (rmol wrd lst)
(map (lambda (x) (srmo wrd x)) lst))

(define (union2 lst)
(if (null? lst) `() (cons (car lst) (union2 (rmol (car lst) (cdr lst))))))

(define (cozum lst)
(union2 (map union (neubind (car lst) (cadr lst)(caddr lst)))))

;finds how much letter requires for control of each degree  
(define (conv lst n)
(cond   ((null? lst) `())
        ((equal? (car lst) "") (cons n (conv (cdr lst) n)))
        ((word? (car lst)) (cons (+ n (count (car lst)))
                                 (conv (cdr lst) (+ n (count (car lst))))))
        (else (conv (cdr lst) (+ n 1)))))

;looks for the conflicts in the solution set for different 
;degrees which is shown in the list(such as last two degree and 
;last three degree)
(define (deepcontrol lst wrd1 wrd2 wrd3 coz)
(cond   ((empty? (cdr lst))(control2 (ls (car lst) wrd1)
                                     (ls (car lst) wrd2)
                                     (ls (car lst) wrd3) coz))
        (else (and (control2 (ls (car lst) wrd1)
                             (ls (car lst) wrd2)
                             (ls (car lst) wrd3) coz)
                   (deepcontrol (cdr lst) wrd1 wrd2 wrd3 coz))))) 

(define (control2 x y z lst)
(or (control (deger x lst) (deger y lst) (deger z lst))
    (control (deger x lst) (deger y lst) (word 1 (deger z lst)))))

(define (control1 x y z lst)
(control (deger x lst) (deger y lst) (deger z lst))) 

(define (control x y z)
(equal? (+ x y) z)) 

(define (deger x lst)
(accumulate word (every (lambda (a) (cadr (assoc a lst))) x)))  

;finds the list of total amounts of letters to control each degree
(define (key wrd1 wrd2 wrd3)
(conv (cozum (list wrd1 wrd2 wrd3)) 0))

;necessity looks for a conflict in the solution set with help of deep
;control 
(define (necessity coz birl wrd1 wrd2 wrd3)
 (let    ((bas (locate (count coz) birl)))
  (if (empty? bas) #t (deepcontrol bas wrd1 wrd2 wrd3 coz))))

(define (locate number lst)
(sublocate number lst 1))

(define (sublocate number lst n)
(cond   ((null? lst) `())
        ((equal? number (car lst))(cons n (sublocate number (cdr lst) (+ n 1))))
        (else (sublocate number (cdr lst) (+ n 1))))) 

;these three function sort the solution set

(define (mergesort lst) 
(if  (<= (count lst) 1)
     lst
     (merge (mergesort (one-half lst))
            (mergesort (other-half lst)))))
 
(define (merge left right)
(cond   ((null? left) right)
        ((null? right) left)
        ((before? (caar left)(caar right))
         (cons (car left) (merge (cdr left) right)))
        (else (cons (car right) (merge left (cdr right)))))) 
 
(define (one-half lst)
(if     (<= (count lst) 1)
        lst 
        (cons (car lst) (one-half (cddr lst)))))
 
(define (other-half lst)
(if     (<= (count lst) 1)
        `()
        (cons (cadr lst)(other-half (cddr lst)))))