Clojure translation of the LISP code in the book "Artificial Intelligence" by George F. Luger

aibook.clj

;; Author: Johan Astborg, 2014 - joastbg@gmail.com
;;
;; Clojure translation of the LISP code in the book:

;; Artificial Intelligence - George F. Luger 
;; Addison Wesley, 4th edition

;; Page 692

(defn my-member [element my-list]
  (cond (nil? my-list) nil
        (= element (first my-list)) my-list
        true (my-member element (next my-list))))

(defn my-length [my-list]
  (cond (nil? my-list) 0
        true (+ (my-length (next my-list)) 1)))

(my-member 1 '(1 2 3 4))
(my-length '(1 2 3 4))

;; Page 693

(defn my-nth [n my-list]
  (cond (zero? n) (first my-list)
        true (my-nth (- n 1) (next my-list))))

(defn filter-negatives [number-list]
  (cond (nil? number-list) nil
        (pos? (first number-list)) (cons (first number-list)
                                         (filter-negatives (next number-list)))
        true (filter-negatives (next number-list))))

(my-nth 2 '(1 2 3 4))
(filter-negatives '(-1 2 3 4 5 -6))

;; Page 694

(defn my-append [list1 list2]
  (cond (nil? list1) list2
        true (cons (first list1) (my-append (next list1) list2))))

(my-append '(1 2 3) '(4 5 6))

;; Page 695

(defn count-atoms [my-list]
  (cond (nil? my-list) 0
        (not (seq? my-list)) 1
        true (+ (count-atoms (first my-list))
                (count-atoms (next my-list)))))

(count-atoms '((1 2) 3 (((4 5 (6))))))

;; Page 697

(defn my-flatten [my-list]
  (cond (nil? my-list) nil
        (not (seq? my-list)) (cons my-list '())
        true (my-append (my-flatten (first my-list)) (my-flatten (next my-list)))))

(my-flatten '(a (b c) (((d) e f))))

;; Page 701

(defn quad-root-2 [a b c]
  (let [temp (Math/sqrt (- (* b b) (* 4 a c)))]
    (conj '() (/ (+ (- b) temp) (* 2 a))
          (/ (- (- b) temp) (* 2 a)))))

(defn quad-root-3 [a b c]
  (let [temp (Math/sqrt (- (* b b) (* 4 a c)))
        denom (* 2 a)]
    (conj '() (/ (+ (- b) temp) denom)
          (/ (- (- b) temp) denom))))
                               
(quad-root-2 1 2 1)
(quad-root-3 1 2 1)

;; Page 703

(defn make-state [f w g c]
  (conj '() c g w f))

(defn farmer-side [state]
  (my-nth 0 state))

(defn wolf-side [state]
  (my-nth 1 state))

(defn goat-side [state]
  (my-nth 2 state))

(defn cabbage-side [state]
  (my-nth 3 state))

(defn unsafe-farmer-takes-self [state]
  (make-state (opposite (farmer-side state))
              (wolf-side state)
              (goat-side state)
              (cabbage-side state)))


;; Page 704
(defn farmer-takes-self [state]
  (safe (make-state (opposite (farmer-side state))
              (wolf-side state)
              (goat-side state)
              (cabbage-side state))))

(defn farmer-takes-wolf [state]
  (cond (= (farmer-side state) (wolf-side state))
        (safe (make-state (opposite (farmer-side state))
                          (opposite (wolf-side state))
                          (goat-side state)
                          (cabbage-side state)))
        true nil))

(defn farmer-takes-goat [state]
  (cond (= (farmer-side state) (goat-side state))
        (safe (make-state (opposite (farmer-side state))
                          (wolf-side state)
                          (opposite (goat-side state))
                          (cabbage-side state)))
        true nil))

(defn farmer-takes-cabbage [state]
  (cond (= (farmer-side state) (cabbage-side state))
        (safe (make-state (opposite (farmer-side state))
                          (wolf-side state)
                          (goat-side state)
                          (opposite (cabbage-side state))))
        true nil))

;; Page 705

(defn opposite [side]
  (cond (= side 'e) 'w
        (= side 'w) 'e))

(defn safe [state]
  (cond (and (= (goat-side state) (wolf-side state)) ; wolf eats goat
             (not (= (farmer-side state) (wolf-side state)))) nil
        (and (= (goat-side state) (cabbage-side state)) ; goat eats cabbage
             (not (= (farmer-side state) (goat-side state)))) nil
        true state))

(defn path [state goal]
  (println state)
  (cond (= state goal) 'success
        true (or (path (farmer-takes-self state) goal)
                 (path (farmer-takes-wolf state) goal)
                 (path (farmer-takes-goat state) goal)
                 (path (farmer-takes-cabbage state) goal))))


;;(path '(w w e e) '(w w w w)) -- Fix this

;; Page 708

(defn filter-evens [number-list]
  (cond (nil? number-list) nil
        (odd? (first number-list))
              (cons (first number-list) (filter-evens (next number-list)))
        true (filter-evens (next number-list))))
              
(filter-evens '(1 2 3 4 5 6))

;; Page 709

(defn map-single [func list]
  (cond (nil? list) nil
        true (cons (func (first list)) 
                   (map-single func (next list)))))

(map-single #(+ % 1) '(1 2 3 4 5 6))
(map-single seq? '(1 2 (3 4) 5 (6 7 8)))

;; Pattern Matching in LISP (p. 715-717)

(def *database* '(((lovelace ada) 50000.00 1234)
                  ((turing alan) 45000.00 3927)
                  ((shelly mary) 35000.00 2850)
                  ((vonNeumann john) 40000.00 7955)
                  ((simon herbert) 50000.00 1374)
                  ((mccarthy john) 48000.00 2864)
                  ((russel bertrand) 35000.00 2950)))

(defn variable? [x]
  (= x '?))

(defn match-atom [pattern1 pattern2]
  (or (= pattern1 pattern2)
      (variable? pattern1)
      (variable? pattern2)))

(defn match [pattern1 pattern2]
  (cond (or (not (seq? pattern1)) (not (seq? pattern2))) ; one of the patterns is atomic
        (match-atom pattern1 pattern2) ; call match-atom, otherwise
        true (and (match (first pattern1) (first pattern2)) ; match both first and next 
            (match (next pattern1) (next pattern2)))))

(defn get-matches [pattern database]
  (cond (nil? database) '()
        (match pattern (first database))
          (cons (first database) (get-matches pattern (next database)))
        true (get-matches pattern (next database))))

(get-matches '((turing alan) 45000.00 3927) *database*)

(get-matches '(? 50000.00 ?) *database*)

(get-matches '((? john) ? ?) *database*)

;; A Recursive Unification Function (p. 717-719)

(defn my-member-in [element my-list]
  (cond (nil? my-list) nil
        (not= seq? my-list) nil
        (= element (first my-list)) my-list
        true (my-member element (next my-list))))

(defn get-binding [var substitution-list]
  (first (filter (complement nil?) (map #(my-member-in var %) substitution-list))))

(first (find (into {} (map #(assoc apa (first %) (second %)) '((1 a) (2 b) (3 c) (4 d)))) 3))
(find (into {} (map #(assoc apa (first %) (second %)) '((a b c) (b c d e) (d e f) (c d e)))) 'd)
(find (into {} (map #(assoc apa (first %) (second %)) '((a . 1) (b . 2) (c . 3) (d . 4)))) 'c)

(defn get-binding-value [binding]
  (next binding))

(defn add-substitution [var pattern substitution-list]
  (conj substitution-list pattern var))

(defn varp [item]
  (and (seq? item)
       (= (count item) 2)
       (= (first item) 'var)))

(defn is-constant-p [item]
  (not (seq? item)))

(defn occursp [var pattern]
  (cond (= var pattern) true
        (or (varp pattern) (is-constant-p pattern)) nil
        true (or (occursp var (first pattern))
                 (occursp var (next pattern)))))

(defn match-var [var pattern substitution-list]
  (cond (= var pattern) substitution-list
        true (let [binding (get-binding var substitution-list)]
               (cond binding (unify (get-binding-value binding) pattern substitution-list)
                     (occursp var binding) 'failed
                     true (add-substitution var pattern substitution-list)))))

(defn unify [pattern1 pattern2 substitution-list]
  (cond (= substitution-list 'failed) 'failed
        (varp pattern1) (match-var pattern1 pattern2 substitution-list)
        (varp pattern2) (match-var pattern2 pattern1 substitution-list)
        (is-constant-p pattern1) 
            (cond (= pattern1 pattern2) substitution-list
                  true 'failed)
        (is-constant-p pattern2) 'failed
        true (unify (next pattern1) (next pattern2)
                    (unify (first pattern1) (first pattern2) substitution-list))))

;; Works almost as in the book
(unify '(p a (var x)) '(p a b) '())
(unify '(p (var y) b) '(p a (var x)) '())
(unify '(p (var x)) '(p (q a (var y))) '())