(load "lisp-unit")
(use-package :lisp-unit)

(load "logic_programming")

(define-test add-assertion
  (qinterpret
    '(assert! (friend Jule June))))

(define-test add-db
  (qinterpret
    '(assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
    '(assert! (job (Bitdiddle Ben) (computer wizard)))
    '(assert! (salary (Bitdiddle Ben) 60000))
    
    '(assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
    '(assert! (job (Hacker Alyssa P) (computer programmer)))
    '(assert! (salary (Hacker Alyssa P) 40000))
    '(assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
    '(assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
    '(assert! (job (Fect Cy D) (computer programmer)))
    '(assert! (salary (Fect Cy D) 35000))
    '(assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
    '(assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
    '(assert! (job (Tweakit Lem E) (computer technician)))
    '(assert! (salary (Tweakit Lem E) 25000))
    '(assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
    
    '(assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
    '(assert! (job (Reasoner Louis) (computer programmer trainee)))
    '(assert! (salary (Reasoner Louis) 30000))
    '(assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
    '(assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
    '(assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
    '(assert! (job (Warbucks Oliver) (administration big wheel)))
    '(assert! (salary (Warbucks Oliver) 150000))
    '(assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
    '(assert! (job (Scrooge Eben) (accounting chief accountant)))
    '(assert! (salary (Scrooge Eben) 75000))
    '(assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
    '(assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
    '(assert! (job (Cratchet Robert) (accounting scrivener)))
    '(assert! (salary (Cratchet Robert) 18000))
    '(assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
    '(assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
    '(assert! (job (Aull DeWitt) (administration secretary)))
    '(assert! (salary (Aull DeWitt) 25000))
    '(assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))))

(define-test simple-search
  (assert-equal 
    '((SALARY (AULL DEWITT) 25000))
    (qinterpret2
      '(salary (Aull DeWitt) ?salary)))
      
  (assert-equal
    '((JOB (BITDIDDLE BEN) (COMPUTER WIZARD)))
    (qinterpret2
      '(job ?who (computer wizard))))
  
  (assert-equal
    '((JOB (FECT CY D) (COMPUTER PROGRAMMER)) (JOB (HACKER ALYSSA P) (COMPUTER PROGRAMMER)))
    (qinterpret2
      '(job ?who (computer programmer))))
  )

(define-test unindexable-assertions
  (qinterpret
    '(assert! ((jay bird) sam 10))
    '(assert! ((jay bird) tom 12)))
    
  (assert-equal
    '(((JAY BIRD) TOM 12))
    (qinterpret2
      '((jay bird) ?who 12)))
    
  (assert-equal
    '(((JAY BIRD) TOM 12)
      ((jay bird) sam 10))
    (qinterpret2
      '((jay bird) ?who ?howmuch)))
  )

(define-test rule-assertion-same-name
  (qinterpret
    '(assert! (walks john))
    '(assert! (has-legs ted))
    '(assert! 
      (rule (walks ?p) 
            (has-legs ?p))))
  
  (assert-equal
    '((walks john) (walks ted))
    (qinterpret2
      '(walks ?who))))

(define-test search-and
  (assert-equal
    '((AND (JOB (HACKER ALYSSA P) (COMPUTER PROGRAMMER)) (SALARY (HACKER ALYSSA P) 40000)))
    (qinterpret2
      '(and (job ?who (computer programmer))
            (salary ?who 40000)))))

(define-test search-or
  (assert-equal
    '((OR (SALARY (HACKER ALYSSA P) 40000) (SALARY (HACKER ALYSSA P) 18000))
      (OR (SALARY (CRATCHET ROBERT) 40000) (SALARY (CRATCHET ROBERT) 18000)))
    (qinterpret2
      '(or (salary ?who 40000) (salary ?who 18000)))))

(define-test search-not
  (assert-equal
    '((AND (JOB (HACKER ALYSSA P) (COMPUTER PROGRAMMER)) (NOT (SALARY (HACKER ALYSSA P) 35000))))
    (qinterpret2
      '(and (job ?who (computer programmer))
            (not (salary ?who 35000))))))    

(define-test lisp-value
  (assert-equal
    '((AND (SALARY (SCROOGE EBEN) 75000) (LISP-VALUE #'> 75000 40000))
       (AND (SALARY (WARBUCKS OLIVER) 150000) (LISP-VALUE #'> 150000 40000))
       (AND (SALARY (BITDIDDLE BEN) 60000) (LISP-VALUE #'> 60000 40000)))
    (qinterpret2
      '(and (salary ?who ?salary)
            (lisp-value #'> ?salary 40000)))))

(define-test unique
  (assert-equal
    '((UNIQUE (JOB (BITDIDDLE BEN) (COMPUTER WIZARD))))
    (qinterpret2
      '(unique (job ?x (computer wizard)))))
  
  (assert-equal
    '((AND (SUPERVISOR (CRATCHET ROBERT) (SCROOGE EBEN)) (UNIQUE (SUPERVISOR (CRATCHET ROBERT) (SCROOGE EBEN))))
      (AND (SUPERVISOR (REASONER LOUIS) (HACKER ALYSSA P)) (UNIQUE (SUPERVISOR (REASONER LOUIS) (HACKER ALYSSA P)))))
    (qinterpret2
    '(and (supervisor ?peon ?boss)
          (unique (supervisor ?others ?boss)))))
  )

(define-test relations
  (qinterpret
    '(assert! (can-do-job (computer wizard) (computer programmer)))
    '(assert! (can-do-job (computer wizard) (computer technician)))
    '(assert! (can-do-job (computer programmer) (computer programmer trainee)))
    '(assert! (can-do-job (administration secretary) (administration big wheel))))
  
  (assert-equal
    '((can-do-job (computer wizard) (computer technician))
      (can-do-job (computer wizard) (computer programmer)))
    (qinterpret2
      '(can-do-job (computer wizard) ?job)))
)

(define-test simple-rule
  (qinterpret
    '(assert!
      (rule (rich ?dude)
            (and (salary ?dude ?s)
                  (lisp-value #'>= ?s 75000)))))
  
  (assert-equal
    '((RICH (SCROOGE EBEN)) (RICH (WARBUCKS OLIVER)))
    (qinterpret2
      '(rich ?who)))
      
  (qinterpret
    '(assert! (rule (same ?x ?x)))
    '(assert!
      (rule (lives-near ?person-1 ?person-2)
        (and (address ?person-1 (?town . ?rest-1))
              (address ?person-2 (?town . ?rest-2))
            (not (same ?person-1 ?person-2))))))
  
  (assert-equal
    '((LIVES-NEAR (AULL DEWITT) (REASONER LOUIS))
      (LIVES-NEAR (AULL DEWITT) (BITDIDDLE BEN)))
    (qinterpret2
      '(lives-near (AULL DEWITT) ?other)))
)
  
(define-test resursive-rule
  (qinterpret
    '(assert! 
      (rule (outranked-by ?staff ?boss)
            (or (supervisor ?staff ?boss)
                (and 
                  (supervisor ?staff ?middle)
                  (outranked-by ?middle ?boss))))))
  
  (assert-equal
    '((OUTRANKED-BY (TWEAKIT LEM E) (BITDIDDLE BEN))
      (OUTRANKED-BY (REASONER LOUIS) (BITDIDDLE BEN))
      (OUTRANKED-BY (FECT CY D) (BITDIDDLE BEN))
      (OUTRANKED-BY (HACKER ALYSSA P) (BITDIDDLE BEN)))
    (qinterpret2
      '(outranked-by ?who (bitdiddle ben)))))
    
(define-test combine-rules
  (qinterpret
    '(assert!
      (rule (wheel ?person)
        (and (supervisor ?middle-manager ?person)
             (supervisor ?x ?middle-manager)))))
  
  (assert-equal
    '((WHEEL (WARBUCKS OLIVER)) 
      (WHEEL (WARBUCKS OLIVER)) 
      (WHEEL (BITDIDDLE BEN)) 
      (WHEEL (WARBUCKS OLIVER))
      (WHEEL (WARBUCKS OLIVER)))
    (qinterpret2
      '(wheel ?who)))
  
  (qinterpret
    '(assert!
      (rule (lives-in ?person ?town)
            (address ?person (?town . ?r)))))
  
  
  (assert-equal
    '((OR (LIVES-IN (FECT CY D) CAMBRIDGE)
        (AND (CAN-DO-JOB (FECT CY D) (COMPUTER TECHNICIAN)) (WHEEL (FECT CY D))))
      (OR (LIVES-IN (HACKER ALYSSA P) CAMBRIDGE)
        (AND (CAN-DO-JOB (HACKER ALYSSA P) (COMPUTER TECHNICIAN)) (WHEEL (HACKER ALYSSA P)))))
    (qinterpret2 
      '(or 
        (lives-in ?p Cambridge)
        (and
          (can-do-job ?p (computer technician))
          (wheel ?p)))))
  )

(define-test list-rules
  (qinterpret
    '(assert!
      (rule (append-to-form () ?y ?y))))
  (qinterpret
    '(assert!
      (rule (append-to-form (?u . ?v) ?y (?u . ?z))
            (append-to-form ?v ?y ?z))))

  (assert-equal
    '((APPEND-TO-FORM (A B C D) (X Y) (A B C D X Y)))
    (qinterpret2
      '(append-to-form (a b c d) (x y) ?w)))
  
  (assert-equal
    '((APPEND-TO-FORM (V W) (X Y) (V W X Y)))
    (qinterpret2
      '(append-to-form ?k (x y) (v w x y))))

  (qinterpret
    '(assert!
      (rule (next-to ?x ?y in (?x ?y . ?u)))))
  (qinterpret
    '(assert!
      (rule (next-to ?x ?y in (?v . ?z))
            (next-to ?x ?y in ?z))))

  (assert-equal
    '((NEXT-TO W X IN (V W X Y)))
    (qinterpret2
      '(next-to ?k x in (v w x y))))

  (qinterpret
    '(assert!
      (rule (last-pair (?elem) (?elem)))))
  (qinterpret
    '(assert!
      (rule (last-pair (?v . ?u) (?l))
            (last-pair ?u (?l)))))
  
  (assert-equal
    '((LAST-PAIR (A B C V R) (R)))
    (qinterpret2
      '(last-pair (a b c v r) ?x)))
)

(run-tests)