4.4 logic programming

4/4/jord/lecture.org

@@ -0,0 +1,159 @@
+* Lecture 8A: Logic Programming, Pt 1
+hal lookin real cute in that shirt!!
+
+last time we looked at how languages are constructed,
+made of two parts:
+  - eval
+    - takes exp and env
+  - apply
+    - takes proc and args
+
+once you have the interpreter, we have the power to play with the
+language. more generally, we have /metalinguistic abstraction/
+
+we can gain control of complexity by inventing new languages
+
+computer programming is only incidentally about getting a computer to
+do something. primarily, it's a way of expressing ideas.
+
+today we are going to apply this idea to build a new language
+
+instead of "building pascal" we are going to make a really different
+language. this lecture is at two simultaneous language levels:
+  - what the language looks like
+  - how it's implemented
+
+lessons to learn:
+  - how different a language can be
+  - how it still comes down to eval/apply
+  - how streams are cool
+
+DECLARATIVE KNOWLEDGE: what is
+
+what if we could bridge the gap between imperative knowledge and
+declarative knowledge.
+
+we might go to this program and tell it some things:
+
+: son-of adam abel
+: son-of adam cain
+: son-of cain enoch
+: son-of enoch irad
+
+once we've told it these facts, we might ask it things
+
+declarative is unbiased as to what to derive. our procedures take a
+certain and give a certain output, specifically. biased to what we are
+asking of it.
+
+let's invent a syntax:
+
+: if (son-of ?x ?y) and
+:  (son-of ?y ?z)
+:    then (grandson ?x ?z)
+
+Logic Programming allow us to express relationships that express what
+is true, check what is true, and find out what is true.
+
+prolog does this, and we are going to build something very similar
+
+--> break
+
+an employee database.
+
+this is the first time they've mentioned a book character by name!
+
+: (job (bitdiddle ben) (computer wizard))
+: (salary (hacker alyssa p) 3500)
+: (supervisor (tweakit lem e) (bitdiddle ben))
+: (address (reasoner louis) (slumerville (pine tree road) 80))
+: ...
+
+once more, the most important thing:
+
+  - primitives
+
+  - means of combination
+
+  - means of abstraction
+
+in this language, we have one primitive, the query:
+
+: (job ?x (computer programmer))
+: (job ?x (computer ?type))
+: (job ?x (computer . ?type))
+
+means of combination, compound queries 
+  (logical operations such as and, not, or):
+
+: (and (job ?x (computer . ?y))
+:      (supervisor ?x ?z))
+
+: (and (salary ?p ?a)
+:      (lisp-value > ?a 30000))
+
+means of abstraction, rules:
+
+: (rule
+:  (bigshot ?x ?dept)
+:  (and
+:   (job ?x (?dept . ?y))
+:   (not (and (supervisor ?x ?z)
+:             (job ?z (?dept . ?w))))))
+
+--> break
+* Lecture 8B: Logic Programming, Pt 2
+we've seen how the query language works, now we can look at how it's
+implemented. 
+
+: (match pattern data dictionary)
+
+can we match this pattern against this data subject to the bindings in
+the dictionary?
+
+the pattern takes in two streams,
+  - the database
+  - dict of var bindings
+
+it's important that all the building blocks (and, not, or) look the
+same from the outside (black box with two stream inputs, one stream
+output)
+
+:      +-----+
+: ---> |     | --->
+:      +-----+
+:         ^
+:         |
+:      ---+
+
+       CLOSURE
+
+--> break
+
+we also need a unifier, to combine multiple patterns
+
+"it looks like this thing is being very clever but it's not being
+really clever at all"
+
+--> break
+
+"let's turn to a more profound question: what do these things mean?"
+
+classic logic!
+
+: all humans are mortal.
+: all greeks are human.
+: socrates is a greek.
+
+: ∴ socrates is a mortal
+
+in our language, not is not not
+
+in logic, not is not true
+
+in our language, not is not deducible
+
+the CLOSED WORLD ASSUMPTION
+
+"anything i dont know cannot be true" -- harry back with the corporate
+					 commentary humor!! lol

4/4/jord/notes.org

@@ -0,0 +1,590 @@
+* 4.4 Logic Programming
+computer science largely deals with imperative (how-to) knowledge.
+
+nondeterministic programs can have multiple values for an expression,
+allowing computation based on relationships rather than single inputs
+and single outputs.
+
+logic programming extends this by combining relational programming
+with a powerful kind of symbolic pattern matching called
+/unification/.
+
+this approach (when it works) is a powerful way to write programs.
+
+we are leveraging ideas of "what is",
+powered by the familiar ideas of "how to"
+
+logic programming is an active field of research
+
+we will implement a query language that is very different from lisp
+
+still, it will share many similar elements with the lisp
+eval/apply interpreter.
+
+/rules/ are to this language as /procedures/ are to lisp
+
+** 4.4.1 deductive information retrieval
+we are going to make a database for tech workers in the greater boston
+area
+
+#+BEGIN_SRC scheme
+  (address (bitdiddle ben) (slumerville (ridge road) 10))
+  (job (bitdiddle ben) (computer wizard))
+  (salary (bitdiddle ben) 60000)
+  (supervisor (bitdiddle ben) (warbucks oliver))
+
+  (address (hacker alyssa p) (cambridge (mass ave) 78))
+  (job (hacker alyssa p) (computer programmer))
+  (salary (hacker alyssa p) 40000)
+  (supervisor (hacker alyssa p) (bitdiddle ben))
+
+  (address (fect cy d) (cambridge (ames street) 3))
+  (job (fect cy d) (computer programmer))
+  (salary (fect cy d) 35000)
+  (supervisor (fect cy d) (bitdiddle ben))
+
+  (address (tweakit lem e) (cambridge (bay street road) 22))
+  (job (tweakit lem e) (computer technician))
+  (salary (tweakit lem e) 25000)
+  (supervisor (tweakit lem e) (bitdiddle ben))
+
+  (address (reasoner louis) (slumerville (pine tree road) 80))
+  (job (reasoner louis) (computer programmer trainee))
+  (salary (reasoner louis) 30000)
+  (supervisor (reasoner louis) (hacker alyssa p))
+
+  (address (warbucks oliver) (swellesley (top heap road)))
+  (job (warbucks oliver) (administration big wheel))
+  (salary (warbucks oliver) 150000)
+
+  (address (scrooge eben) (weston (shady lane) 10))
+  (job (scrooge eben) (accounting chief accountant))
+  (salary (scrooge eben) 75000)
+  (supervisor (scrooge eben) (warbucks oliver))
+
+  (address (cratchet robert) (allston (n harvard street) 16))
+  (job (cratchet robert) (accounting scrivener))
+  (salary (cratchet robert) 18000)
+  (supervisor (cratchet robert) (scrooge eben))
+
+  (address (aull dewitt) (slumerville (onion square) 5))
+  (job (aull dewitt) (administration secretary))
+  (salary (aull dewitt) 25000)
+  (supervisor (aull dewitt) (warbucks oliver))
+
+
+  (can-do-job (computer wizard) (computer programmer))
+  (can-do-job (computer wizard) (computer technician))
+  (can-do-job (computer programmer) (computer programmer trainee))
+  (can-do-job (administration secretary) (administration big wheel))
+#+END_SRC
+
+we can conduct simple queries on the data
+: (job ?x (computer programmer))
+
+to view all addresses
+: (address ?x ?y)
+
+to find anyone in the computer dept
+: (job ?x (computer . ?type))
+
+(computer . ?type) matches both
+  (computer programmer)
+    and 
+  (computer programmer trainee)
+
+compound queries can be formed with the logical operators
+  - and
+  - or
+  - not
+
+: (and (job ?person  (computer programmer))
+:      (address ?person ?where))
+
+we can also use lisp-value to pass thru to a lisp predicate
+
+we can abstract queries with rules
+: (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))))
+
+the same relationship is defined with a simple rule
+: (rule (same ?x ?x))
+
+THE LOGIC FOR LISTS
+append can be implemented as follows
+
+: (rule (append-to-form () ?y ?y))
+
+: (rule (append-to-form (?u . ?v) ?y (?u . ?z))
+:       (append-to-form ?v ?y ?z))
+
+then we can run:
+: (append-to-form (a b) (c d) ?z)
+and get the result:
+: (append-to-form (a b) (c d) (a b c d))
+
+** 4.4.2 how the query system works
+the query system is based around
+  /pattern matching/ and /unification/
+
+PATTERN MATCHING
+
+a pattern matcher is a program that tests wether some datum fits a
+given pattern
+
+e.g.
+  ((a b) c (a b)) matches (?x c ?x)
+
+simple queries that don't involve rules only require the pattern
+matcher. for each match found, a frame will be returned with a value
+bound to the variables (?x)
+
+a query takes an input stream of frames and performes matching for
+each frame in the stream and generates a new stream of all all matches
+to assertions in the database
+
+with compound queries, one stream is produced and then combined with
+the stream for the other part of the compound.
+
+`not` queries remove matching patterns from the frame stream
+
+UNIFICATION
+
+a unifier takes two pattens, each with constants and variables, and
+determines if values can be assigned to variables to produce a true
+statement
+
+the interpretation of queries is much like the lisp eval/apply
+
+** 4.4.3 is logic programming mathematical logic?
+no
+
+this chapter brutal with the corporate social commentary lol
+
+we should be careful of the easy trap of infinite loops
+
+** 4.4.4 implementing the query system
+*** 4.4.4.1 the driver loop and intstantiation
+#+BEGIN_SRC scheme
+  (define input-prompt ";;; Query input:")
+  (define output-prompt ";;; Query results:")
+
+  (define (query-driver-loop)
+    (prompt-for-input input-prompt)
+    (let ((q (query-syntax-process (read))))
+      (cond ((assertion-to-be-added? q)
+	     (add-rule-or-assertion! (add-assertion-body q))
+	     (newline)
+	     (display "Assertion added to data base.")
+	     (query-driver-loop))
+	    (else
+	     (newline)
+	     (display output-prompt)
+	     (display-stream
+	      (stream-map
+	       (lambda (frame)
+		 (instantiate q
+			      frame
+			      (lambda (v f)
+				(contract-question-mark v))))
+	       (qeval q (singleton-stream '()))))
+	     (query-driver-loop)))))
+  (define (instantiate exp frame unbound-var-handler)
+    (define (copy exp)
+      (cond ((var? exp)
+	     (let ((binding (binding-in-frame exp frame)))
+	       (if binding
+		   (copy (binding-value binding))
+		   (unbound-var-dandler exp frame))))
+	    ((pair? exp)
+	     (cons (copy (car exp)) (copy (cdr exp))))
+	    (else exp)))
+    (copy exp))
+#+END_SRC
+
+*** 4.4.4.2 the evaluator
+#+BEGIN_SRC scheme
+  (define (qeval query frame-stream)
+    (let ((qproc (get (type query) 'qeval)))
+      (if qproc
+	  (qproc (contents query) frame-stream)
+	  (simple-query query frame-stream))))
+
+  (define (simple-query query-pattern frame-stream)
+    (stream-flatmap
+     (lambda (frame)
+       (stream-append-delayed
+	(find-assertions query-pattern frame)
+	(delay (apply-rules query-pattern frame))))
+     frame-stream))
+
+  (define (conjoin conjuncts frame-stream)
+    (if (empty-conjunction? conjuncts)
+	frame-stream
+	(conjoin (rest-conjuncts conjuncts)
+		 (qeval (first-conjunct conjuncts)
+			frame-stream))))
+  (put 'and 'queval conjoin)
+
+  (define (disjoin disjuncts frame-stream)
+    (if (empty-disjunction? disjuncts)
+	the-empty-stream
+	(interleave-delayed
+	 (qeval (first-disjunct disjuncts) frame-stream)
+	 (delay (disjoin (rest-disjuncts disjuncts)
+			 frame-stream)))))
+  (put 'or 'qeval disjoin)
+
+  (define (negate operands frame-stream)
+    (stream-flatmap
+     (lambda (frame)
+       (if (stream-null? (qeval (negated-query operands)
+				(singleton-stream frame)))
+	   (singleton-stream frame)
+	   the-empty-stream))
+     frame-stream))
+  (put 'not 'qeval negate)
+
+  (define (lisp-value call frame-stream)
+    (stream-flatmap
+     (lambda (frame)
+       (if (execute
+	    (instantiate
+	     call
+	     frame
+	     (lambda (v f)
+	       (error "unknown pat var -- LISP-VALUE" v))))
+	   (singleton-stream frame)
+	   the-empty-stream))
+     frame-stream))
+  (put 'lisp-value 'qeval lisp-value)
+
+  (define (execute exp)
+    (apply (eval (predicate exp) user-initial-environment)
+	   (args exp)))
+
+  (define (always-true ignore frame-stream) frame-stream)
+  (put 'always-true 'qeval always-true)
+
+#+END_SRC
+
+*** 4.4.4.3 finding assertions by pattern matching
+#+BEGIN_SRC scheme
+  (define (find-assertions pattern frame)
+    (stream-flatmap (lambda (datum)
+		      (check-an-assertion datum pattern frame))
+		    (fetch-assertions pattern frame)))
+
+  (define (check-an-assertion assertion query-pat query-frame)
+    (let ((match-result
+	   (pattern-match query-pat assertion query-frame)))
+      (if (eq? match-result 'failed)
+	  the-empty-stream
+	  (singleton-stream match-result))))
+
+  (define (pattern-match pat dat frame)
+    (cond ((eq? frame 'failed) 'failed)
+	  ((equar? pat dat) frame)
+	  ((var? pat) (extend-if-consistent pat dat frame))
+	  ((and (pair? pat) (pair? dat))
+	   (pattern-match (cdr pat)
+			  (cdr dat)
+			  (pattern-match (car pat)
+					 (car dat)
+					 frame)))
+	  (else 'failed)))
+
+  (define (extend-if-consistent var dat frame)
+    (let ((binding (binding-in-frame var frame)))
+      (if binding
+	  (pattern-match (binding-value binding) dat frame)
+	  (extend var dat frame))))
+#+END_SRC
+
+*** 4.4.4.4 rules and unification
+#+BEGIN_SRC scheme
+  (define (apply-rules pattern frame)
+    (stream-flatmap (lambda (rule)
+		      (apply-a-rule rule pattern frame))
+		    (fetch-rules pattern frame)))
+
+  (define (apply-a-rule rule query-pattern query-frame)
+    (let ((clean-rule (rename-variables-in rule)))
+      (let ((unify-result
+	     (unify-match query-pattern
+			  (conclusion clean-rule)
+			  query-frame)))
+	(if (eq? unify-result 'failed)
+	    the-empty-stream
+	    (qeval (rule-body clean rule)
+		   (singleton-stream unify-result))))))
+
+  (define (rename-variables-in rule)
+    (let ((rule-application-id (new-rule-application-id)))
+      (define (tree-walk exp)
+	(cond ((var? exp)
+	       (make-new-variable exp rule-application-id))
+	      ((pair? exp)
+	       (cons (tree-walk (car exp))
+		     (tree-walk (cdr exp))))
+	      (else exp)))
+      (tree-walk rule)))
+
+  (define (unify-match p1 p2 frame)
+    (cond ((eq? frame 'failed) 'failed)
+	  ((equal? p1 p2) frame)
+	  ((var? p1) (extend-if-possible p1 p2 frame))
+	  ((var? p1) (extend-if-possible p2 p1 frame))
+	  ((and (pair? p1) (pair? p2))
+	   (unify-match (car p1)
+			(car p2)
+			(unify-match (car p1)
+				     (car p2)
+				     frame)))
+	  (else 'failed)))
+
+  (define (extend-if-possible var val frame)
+    (let ((binding (binding-in-frame var frame)))
+      (cond (binding
+	     (unify-match
+	      (binding-value binding) val frame))
+	    ((var? val)
+	     (let ((binding (binding-in-frame val frame)))
+	       (if binding
+		   (unify-match
+		    var (binding-value binding) frame)
+		   (extend var val frame))))
+	    ((depends-on? val var frame)
+	     'failed)
+	    (else (extend var val frame)))))
+
+  (define (depends-on? exp var frame)
+    (define (tree-walk e)
+      (cond ((var? e)
+	     (if (equal? var e)
+		 true
+		 (let ((b (binding-in-frame e frame)))
+		   (if b
+		       (tree-walk (binding-value b))
+		       false))))
+	    ((pair? e)
+	     (or (tree-walk (car e))
+		 (tree-walk (cdr e))))
+	    (else false)))
+    (tree-walk exp))
+#+END_SRC
+
+*** 4.4.4.5 maintaining the database
+#+BEGIN_SRC scheme
+  (define THE-ASSERTIONS the-empty-stream)
+
+  (define (fetch-assertions pattern frame)
+    (if (use-index? pattern)
+	(get-indexed-assertions pattern)
+	(get-all-assertions)))
+
+  (define (get-all-assertions) THE-ASSERTIONS)
+
+  (define (get-indexed-assertions pattern)
+    (get-stream (index-key-of pattern) 'assertion-stream))
+
+  (define (get-stream key1 key2)
+    (let ((s (get key1 key2)))
+      (if s s the-empty-stream)))
+
+  (define THE-RULES the-empty-stream)
+
+  (define (fetch-rules pattern frame)
+    (if (use-index? pattern)
+	(get-indexed-rules pattern)
+	(get-all-rules)))
+
+  (define (get-all-rules) THE-RULES)
+
+  (define (get-indexed-rules pattern)
+    (stream-append
+     (get-stream (index-key-of pattern) 'rule-stream)
+     (get-stream '? 'rule-stream)))
+
+  (define (add-rule-or-assertion! assertion)
+    (if (rule? assertion)
+	(add-rule! assertion)
+	(add-assertion! assertion)))
+
+  (define (add-assertion! assertion)
+    (store-assertion-in-index assertion)
+    (let ((old-assertions THE-ASSERTIONS))
+      (set! THE-ASSERTIONS
+	    (cons-stream assertion old-assertions))
+      'ok))
+
+  (define (add-rule! rule)
+    (store-rule-in-index rule)
+    (let ((old-rules THE-RULES))
+      (set! THE-RULES
+	    (cons-stream rule old-rules))
+      'ok))
+
+  (define (store-assertion-in-index assertion)
+    (if (indexable? assertion)
+	(let ((key (index-key-of assertion)))
+	  (let ((current-assertion-stream
+		 (get-stream key 'assertion-stream)))
+	    (put key
+		 'assertion-stream
+		 (cons-stream assertion
+			      current-assertion-stream))))))
+
+  (define (store-rule-in-index rule)
+    (let ((pattern (conclusion rule)))
+      (if (indexable? pattern)
+	  (let ((key (index-key-of pattern)))
+	    (let ((current-rule-stream
+		   (get-stream key 'rule-stream)))
+	      (put key
+		   'rule-stream
+		   (cons-stream rule
+				current-rule-stream)))))))
+
+  (define (indexable? pat)
+    (or (constant-symbol? (car pat))
+	(var? (car pat))))
+
+  (define (index-key-of pat)
+    (let ((key (car pat)))
+      (if (var? key) '? key)))
+
+  (define (use-index? pat)
+    (constant-symbol? (car pat)))
+#+END_SRC
+
+*** 4.4.4.6 stream operations
+#+BEGIN_SRC scheme
+  (define (stream-append-delayed s1 delayed-s2)
+    (if (stream-null? s1)
+	(force delayed-s2)
+	(cons-stream
+	 (stream-car s1)
+	 (strea-append-delayed (stream-cdr s1) delayed-s2))))
+
+  (define (interleave-delayed s1 delayed-s2)
+    (if (stream-null? s1)
+	(force delayed-s2)
+	(cons-stream
+	 (stream-car s1)
+	 (interleave-delayed (force delayed-s2)
+			     (delay (stream-cdr s1))))))
+
+  (define (stream-fatmap proc s)
+    (flatten-stream (stream-map proc s)))
+
+  (define (flatten-stream stream)
+    (if (stream-null? stream)
+	the-empty-stream
+	(interleave-delayed
+	 (stream-car stream)
+	 (delay (flatten-stream (stream-cdr stream))))))
+
+  (define (singleton-stream x)
+    (cons-stream x the-empty-stream))
+#+END_SRC
+
+*** 4.4.4.7 query syntax procedures
+#+BEGIN_SRC scheme
+  (define (type exp)
+    (if (pair? exp)
+	(car exp)
+	(error "unknown exp TYPE" exp)))
+
+  (define (contents exp)
+    (if (pair? exp)
+	(cdr exp)
+	(error "unknown exp CONTENTS" exp)))
+
+  (define (assertion-to-be-added? exp)
+    (eq? (type exp) 'assert!))
+  (define (add-assertion-body exp)
+    (car (contents exp)))
+
+  (define (empty-conjunction? exps) (null? exps))
+  (define (first-conjunct exps) (car exps))
+  (define (rest-conjuncts exps) (cdr exps))
+
+  (define (empty-disjunction? exps) (null? exps))
+  (define (first-disjunct exps) (car exps))
+  (define (rest-disjuncts exps) (cdr exps))
+
+  (define (negated-query exps) (car exps))
+
+  (define (predicate exps) (car exps))
+  (define (args exps) (cdr exps))
+
+  (define (rule? statement)
+    (tagged-list? statement 'rule))
+
+  (define (conclusion rule) (cadr rule))
+
+  (define (rule-body rule)
+    (if (null? (cddr rule))
+	'(always-true)
+	(caddr rule)))
+
+  (define (query-syntax-process exp)
+    (map-over-symbols expand-question-mark exp))
+
+  (define (map-over-symbols proc exp)
+    (cond ((pair? exp)
+	   (cons (map-over-symbols proc (car exp))
+		 (map-over-symbols proc (cdr exp))))
+	  ((symbol? exp) (proc exp))
+	  (else exp)))
+
+  (define (expand-question-mark symbol)
+    (let ((chars (symbol->string symbol)))
+      (if (string=? (substring chars 0 1) "?")
+	  (list '?
+		(string->symbol
+		 (substring chars 1 (string-length chars))))
+	  symbol)))
+
+  (define (var? exp)
+    (tagged-list? exp '?))
+
+  (define (constant-symbol? exp) (symbol? exp))
+
+  (define rule-counter 0)
+
+  (define (new-rule-application-id)
+    (set! rule-counter (+ 1 rule-counter))
+    rule-counter)
+
+  (define (make-new-variable var rule-application-id)
+    (cons '? (cons rule-application-id (cdr var))))
+
+  (define (contract-question-mark variable)
+    (string->symbol
+     (string-append "?"
+		    (if (number? (cadr variable))
+			(string-append (symbol->string (caddr variable))
+				       "-"
+				       (number->string (cadr variable)))
+			(symbol->string (cadr variable))))))
+#+END_SRC
+
+*** 4.4.4.8 frames and bindings
+#+BEGIN_SRC scheme
+  (define (make-binding variable value)
+    (cons variable value))
+  (define (binding-variable binding)
+    (car binding))
+  (define (binding-value binding)
+    (cdr binding))
+  (define (binding-in-frame variable frame)
+    (assoc variable frame))
+  (define (extend variable value frame)
+    (cons (make-binding variable value) frame))
+#+END_SRC
+
+wham, bam, thank you ma'am!