;;; PYTHAG.CL
;;; "Pythagoras" -- a program that demonstrates heuristically-guided
;;; concept formation in mathematics.

;;; (C) Copyright 1995 by Steven L. Tanimoto.
;;; This program is described in Chapter 10 ("Learning") of
;;; "The Elements of Artificial Intelligence Using Common Lisp," 2nd ed.,
;;; published by W. H. Freeman, 41 Madison Ave., New York, NY 10010.
;;; Permission is granted for noncommercial use and modification of
;;; this program, provided that this copyright notice is retained
;;; and followed by a notice of any modifications made to the program.

;;; Structure of the concept exploration system:
;;; There is an "agenda" (prioritized list of tasks)
;;; which is continually updated by the insertion of new
;;; tasks and the deletion of tasks that are completed.
;;; Each task is a specification for some activity.
;;; The function EXPLORE-CONCEPTS is a procedure which repeatedly
;;; takes the task of highest priority off the agenda and performs
;;; it with the help of other functions.

;;; An item on the agenda has the form: 
;;;	 (interest-value (Task-spec))

;;; There are two kinds of tasks, and their specifications
;;;  have the following forms:

;;;	(MAKE-SPECIALIZATION concept)
;;;	(FIND-EXAMPLES-OF concept) 

;;; -----------------------------------------------------------------
;;; The concepts under investigation are classes of geometric figures
;;; that can be derived from the most general class "OBJECT" using
;;; specialization through restrictive predicates.
;;; Since these predicates will be applied to actual geometric figures
;;; during the course of the program's exploration, we must define the
;;; representation scheme for the geometric figures.  For this program,
;;; they are all polygons.

;;; A polygon is represented as a list of points,
;;; and a point is a pair of coordinate values.
;;; The set of polygons used in the explorations
;;; is referred to as the "universe of objects" and
;;; it is defined as follows:

(defparameter *universe*
  '(*box* *square* *isosceles* *right-triangle*
      *trapezoid* *parallelogram* *rhombus* *multi*
      *line* *dot*) )

(defparameter *box* '((0 0) (0 5) (10 5) (10 0)) )
(defparameter *square* '((0 0) (0 10) (10 10) (10 0)) )
(defparameter *isosceles* '((0 0) (5 5) (10 0)) )
(defparameter *right-triangle* '((0 0) (4 3) (4 0)) )
(defparameter *trapezoid* '((0 0) (5 5) (20 5) (25 0)) )
(defparameter *parallelogram* '((0 0) (5 5) (15 5) (10 0)) )
(defparameter *rhombus* '((0 0) (4 3) (9 3) (5 0)) )
(defparameter *multi* '((0 0) (0 10) (4 15) (10 15) (15 10)
                          (15 4) (10 0) ) )
(defparameter *line* '((0 0) (10 0)) )
(defparameter *dot* '((0 0)) )

;;; -----------------------------------------------------------------

;;; A collection of predicates for the purpose of forming specializations
;;; is provided below:

(defparameter *predicates*
  '(equal-sides nonzero-area many-sides) )

;;; MANY-SIDES is true if P has more than 6 sides.
(defun many-sides (p)
  "Returns T if P has more than 6 sides."
  (> (length p) 6) )

;;; NONZERO-AREA is true if the area of P is not equal to zero.
(defun nonzero-area (p)
  "Returns T if P has nonzero area."
  (not (zerop (area p))) )

;;; AREA computes the area enclosed by polygon P.
(defun area (p)
  "Computes the area enclosed by polygon P."
  (/ (area1 p (first p)) 2) )

;;; AREA1 computes twice the sum of the areas under each segment.
;;; FIRST-PT is the first point of the polygon P when called
;;; at its top level.  It's used to make sure the last segment
;;; of the polygon is considered --- the one from the last point
;;; to the first point.
(defun area1 (p first-pt)
  "Returns 2 times the sum of the areas under the segments of P."
  (if (null (rest p))
      (* (dx first-pt (first p))
         (py first-pt (first p)) )
      (+ (area1 (rest p) first-pt)
         (* (dx (second p) (first p))
            (py (second p) (first p)) ) ) ) )

;;; EQUAL-SIDES is true if all sides of P have equal length.
(defun equal-sides (p)
  "Returns T if all sides of P have equal length."
  (apply #'= (side-length-sq-list p (first p))) )

;;; SIDE-LENGTH-SQ-LIST makes a list of squared lengths of
;;; the sides of P.
(defun side-length-sq-list (p first-pt)
  "Returns a list of the squared lengths of the sides of P."
  ( if (null (rest p))
       ;; last side connects to 1st point...
       (list (+ (sq (dx first-pt (first p)))
                (sq (dy first-pt (first p))) ))
       ;; other sides connect successive points...
       (cons (+ (sq (dx (second p) (first p)))
                (sq (dy (second p) (first p))) )
             (side-length-sq-list (rest p) first-pt) ) ) )

;;; SQ computes N squared.
(defun sq (n)
  "Returns N squared."
  (* n n) )

;;; DX, DY, PY, XC and YC are helping functions for
;;; coordinate arithmetic:
(defun dx (pt1 pt2) (- (xc pt1) (xc pt2)))

(defun dy (pt1 pt2) (- (yc pt1) (yc pt2)))

(defun py (pt1 pt2)
  "Returns the sum of the y coords of PT1 and PT2."
  (+ (yc pt1) (yc pt2)) )

(defun xc (pt) (first pt)) ; Get X coordinate of point.

(defun yc (pt) (second pt)); Get Y coordinate of point.

;;; declare global variables:
(defvar *reporting* nil)
(defvar *agenda* nil)
(defvar *concept-counter* nil)

;;; Let us now define the CONCEPT structure with 13 slots.
;;; In the following structure definition, we use several
;;; options, including specifying a special function
;;; for printing concepts, as well as default values for
;;; various slots. 
(defstruct (concept (:print-function briefly-print-concept))
  (id (new-atom))
  defn
  predicate
  interest
  (objects-to-try *universe*)
  (examples-found nil)
  (unused-predicates *predicates*)
  predicates-used-in-spec
  predicates-used-in-desc
  (number-found 0)
  (number-tried 0)
  parent
  subconcepts
  )

;;; The following function is used during debugging.
;;; Without it, tracing a function that manipulates
;;; a concept leads to an infinite print recursion
;;; due to the fact that parent and child concepts
;;; cyclically reference each other.
(defun briefly-print-concept (c stream level)
  "Provides a way to print out concepts without
   infinite recursion."
  (declare (ignore level))
  ;; Note (DECLARE (IGNORE LEVEL)) suppresses compiler warning.
  (format stream "~A" (concept-id c)) )


;;; -----------------------------------------------------------------
;;; To find examples, the procedure FIND-EXAMPLES-OF takes the list of
;;; objects not yet tried and tries a fixed number of them, (3 of them).
;;; It puts any examples found on the list of examples for the concept,
;;; and it updates the list of objects left to try.
;;; This procedure also does the following:
;;; It updates the interest value for the concept in accordance to
;;; the results of looking for examples.
(defun find-examples-of (c)
  "Tests objects for being examples of concept C, and updates
   the agenda according to the findings."
  (let ((objects-left (concept-objects-to-try c))
        x)
    ;; Test 3 objects not yet tried as possible examples of C:
    (dotimes (i 3 nil)
      (if (null objects-left)        
          (return (setf (concept-objects-to-try c) nil)) )
      (setf x (pop objects-left))
      (incf (concept-number-tried c)) ; doesn't work in Allegro 4.1
      (pop (concept-objects-to-try c))
      (cond ((apply (concept-predicate c) (list (eval x)))
             ;; An example has been found...
             (format t "~%~a is an example of concept ~a." 
               x (concept-id c))
             (setf (concept-examples-found c)
                   (adjoin x (concept-examples-found c)) )

             (incf (concept-number-found c)) )
            ;; But if the object is not an example...
            (t (format t
                 "~%~a is not an example of concept ~a."
                 x (concept-id c) )) ) )

    ;; The example-checking part of this task is over.
    ;; Now update the interest value for C:
    (setf (concept-interest c) (compute-concept-interest c))
    ;; If there are still objects not yet tried, enter a new 
    ;; task on the agenda to try 3 more objects.
    (if objects-left
        (put-on-agenda
          `(,(examples-task-interest c) ; Compute interest val.
                (find-examples-of ,c) ) )
        (if *reporting*
            (format t "~%All objects now tested for ~a."
                 (concept-id c) ) ) )
            
    (if *reporting* (display-agenda *agenda*))
    ;; If there is at least one example of the concept and no
    ;; specializations for this concept have yet been created,
    ;; and no tasks for such specialization are already on the
    ;; agenda, create a new task to make a specialization of C:
    (if (and (> (concept-number-found c) 0)
             (null (concept-subconcepts c))
             (no-spec-task *agenda* (concept-id c)) )
        (put-on-agenda
          `(,(spec-task-interest c) ; Compute task interest.
                (make-specialization ,c) ) ) )

    ;; Print out a current description of the concept:
    (display-concept c)
    ;; The FIND-EXAMPLES-OF task has now been completed.
    ) )

;;; PUT-ON-AGENDA inserts an entry of the form
;;; (interest-value (task-spec))  onto the agenda,
;;; in its place, so that items are ordered, highest
;;; interest-value first.
(defun put-on-agenda (task)
  "Inserts TASK in the priority queue *AGENDA*."
  (setf *agenda* (put-on-agenda1 task *agenda*)) )

;;; PUT-ON-AGENDA1 is the recursive slave to put-on-agenda.
(defun put-on-agenda1 (task task-list)
  "Handles the insertion of TASK in the right place."
  (cond ((null task-list) (list task))
        ((< (first task) (caar task-list))
         (cons (first task-list)
               (put-on-agenda1 task (rest task-list)) ) )
        (t (cons task task-list)) ) )

(defun no-spec-task (agenda c)
  "Returns T if no MAKE-SPECIALIZATION task
   with concept id C is on AGENDA."
  (not
    (member c agenda
      :test
      #'(lambda (x y)
          (and (eql (caadr y) 'make-specialization)
               (eql x (concept-id (cadadr y))) ) ) ) ) )

;;; CONCEPT-INTEREST computes the current interest value
;;; for concept C using a formula that involves the hit ratio. 
(defun compute-concept-interest (c)
  "Returns the INTEREST value for C using heuristic formula."
  (if (zerop (concept-number-tried c))
      (concept-interest (concept-parent c))
      (let ((r (/ (concept-number-found c)
                  (concept-number-tried c) )))
        (* 400.0 (- r (* r r))) ) ) )

;;; EXAMPLES-TASK-INTEREST computes the interest of a task to
;;; find examples of C as a weighted sum of the interests of
;;; C and it parent.
(defun examples-task-interest (c)
  "Returns the interest value of a FIND-EXAMPLES-OF task."
  (+ (* 0.8 (concept-interest (concept-parent c)))
     (* 0.2 (concept-interest c)) ) )

;;; SPEC-TASK-INTEREST computes the interest value 
;;; for a specialization task, according to the formula:
;;;  value = 10 times the parent's hit ratio.
;;; We add one to the denominator to avoid the possibility
;;; of division by zero.
(defun spec-task-interest (c)
  "Returns the interest value of a MAKE-SPECIALIZATION task."
  (/ (* 10.0 (concept-number-found c))
     (1+ (concept-number-tried c)) ) )

; -----------------------------------------------------------------
; A task of type MAKE-SPECIALIZATION requires that the system
;  attempt to create a representation for a new concept.
; To create a new concept, the function MAKE-SPECIALIZATION
;  creates a structure containing  the following:
; - A unique id which is a symbol, e.g., C1, C2, etc.
; - A definition of the concept in terms of the parent concept.
;   suitable for an explanatory printout.
; - A predicate that can be applied to any object
;   to determine whether it is an example of this concept.
; - An interest value for the concept computed using a rule
;   which takes into account the interest of the parent concept
;   and the interest of the predicate used to form the restriction.
; - A list of objects that have not yet been tried as possible examples,
;   initially the whole "UNIVERSE".
; - A list of examples found.
; - A list of the predicates NOT used in the definition of this concept -
;   this simplifies the procedure MAKE-SPECIALIZATION.
; - A list of the original (provided) predicates that have been used
;   along the path from OBJECT to this concept (used in DISPLAY-CONCEPTS).
; - A list of the predicates that have been used to create specializations
;   of this concept.
; - The number of examples found (so far).
; - The number of objects tried (so far).
; - A parent concept.
; - A list of subconcepts.
; These items are put on the property list of the atom under the
; types: ID, DEFN, PREDICATE, INTEREST, OBJECTS-TO-TRY, EXAMPLES-FOUND,
;	UNUSED-PREDICATES, PREDICATES-USED-IN-SPEC, 
;	PREDICATES-USED-IN-DESC, NUMBER-FOUND, NUMBER-TRIED,
;       PARENT, SUBCONCEPTS.
(defun make-specialization (c)
  "Performs a MAKE-SPECIALIZATION task."
  (let ((pred 
           ;; Select a predicate not already involved in the parent
           ;;  and not already used for a specialization of C.
           (select-pred (concept-unused-predicates c)
                        (concept-predicates-used-in-spec c) ))
        newc)

    (cond ((null pred)
           (if *reporting*
               (format t "~%Cannot further specialize concept ~a."
                    (concept-id c) ) )
           (return-from make-specialization nil) ) )
    ;; Indicate that the selected predicate is no longer available
    ;;  for other specializations of C:
    (push pred (concept-predicates-used-in-spec c))
		 
    ;; Create a new concept structure and make up a new ID...
    (setf newc (make-concept))
    ;; Set up links in concept hierarchy...
    (make-isa newc c)
    ;; Register the list of unused predicates for the new concept: 
    (setf (concept-unused-predicates newc)
          (remove pred (concept-unused-predicates c)) )

    ;; Formulate the definition of NEWC:
    (setf (concept-defn newc)
      (append '(an instance of)(list (concept-id newc))
              '(is a)(list (concept-id (concept-parent newc)))
              '(having)(list pred)) )
		 
    ;; Create the predicate which tests an object to see if
    ;;  it is an example of the new concept:
    (setf (concept-predicate newc)
          (create-concept-predicate newc c pred) )

    ;; Store the list of predicates that should be used to
    ;;  describe this concept:
    (setf (concept-predicates-used-in-desc newc)
          (cons pred (concept-predicates-used-in-desc c)) )

    ;; Set up a task to find examples of the new concept:
    (put-on-agenda
      ;; interest = interest of parent concept.
       `(,(concept-interest c)
            (find-examples-of ,newc) ) )
    ;; Set up a task to make another specialization of C:
    (put-on-agenda
      `(,(spec-task-interest c)
            (make-specialization ,c) ) )
    ) )

;;; SELECT-PRED returns a member of L1 - L2.
;;; Used to selects a predicate from those available
;;; and not yet used for specializing this concept.
(defun select-pred (l1 l2)
  "Returns a member of L1 not in L2."
  (let ((p (set-difference l1 l2)))
    (if (null p) nil (first p)) ) )


;;; NEW-ATOM returns a new atom each time it is called,
;;; beginning with C1, then C2, etc.
(defun new-atom ()
  "Returns a new symbol: first C1, then C2, etc."
  (incf *concept-counter*)
  (intern
    (concatenate 'string
                 "C"
                 (prin1-to-string *concept-counter*) ) ) )

(defun create-concept-predicate (newc c pred)
  "Creates a predicate which tests an object to see if
   it is an example of the concept NEWC, using the
   existing predicate for the parent concept C."
  (let
    ((new-predicate
       #'(lambda (obj) 
           (and (apply pred (list obj))
                (apply (concept-predicate c) (list obj)) ) ) ))
    ;; If reporting is enabled, show predicate:
    (if *reporting*
        (format t "~%Creating concept ~a with predicate: ~s"
                (concept-id newc) new-predicate) )
    new-predicate) )

;;; EXPLORE-CONCEPTS contains the main control loop.
(defun explore-concepts ()
  "Top-level loop for concept exploration."
  (let (current-task)
    (loop
      (if (null *agenda*) (return))
      ;; Select task at head of agenda...
      (setf current-task (second (first *agenda*)))
      (pop *agenda*)  ; Remove it from the agenda.
      (funcall (first current-task)
               (second current-task) ) ; Perform current task.
        ) ) )

;;; Functions for manipulating the concept hierarchy:

;;; ADD-SUBSET records the fact that X is a subset of Y.
(defun add-subset (x y)
  "Inserts X into the list of subconcepts of Y."
  (setf (concept-subconcepts y)
        (adjoin x (concept-subconcepts y)) ) )

;;; ADD-SUPERSET records the fact that X is a superset of Y.
(defun add-superset (x y)
  "Makes X be the parent of Y."
  (setf (concept-parent y) x) )

;;; MAKE-ISA sets up a bi-directional ISA link between X and Y.
(defun make-isa (x y)
  "Creates 2-way ISA hierarchy link."
  (add-superset y x)
  (add-subset x y) )

;-----------------------------------------------------------

;;; INITIALIZE sets up the concept hierarchy to contain a single
;;; concept, "OBJECT" from which specializations will be made.
(defvar *object*)
(setf *dummy* (make-concept :id 'dummy))
(defvar *dummy*)

(defun initialize ()
  "Sets the concept OBJECT to the unprocessed state,
   and initializes the agenda and counter for concepts."
  (setf *object* (make-concept
    :id 'object
    :predicate
      #'(lambda (x) (declare (ignore x)) t)  ; always true.
     ;; Note (DECLARE (IGNORE X)) suppresses compiler warning.
    :unused-predicates *predicates*
    :predicates-used-in-spec nil
    :interest 50) )

  ;; One of the interest-computing functions wants '*OBJECT* to
  ;;  have a parent concept, so we set up a *DUMMY*:
  (make-isa *object* *dummy*)
  (setf (concept-interest *dummy*) 50)

  ;; Start the concept counter at 0:
  (setf *concept-counter* 0)

  ;; Set up the initial agenda of tasks:
  (setf *agenda*
    `((50 (find-examples-of ,*object*))
      (25 (make-specialization ,*object*)) ) ) )


;;; DISPLAY-CONCEPT prints out the status of a concept.
(defun display-concept (c)
  "Prints parts of the description of concept C,
   without any infinitely recursive printing."
  (format t "~%~%Status of concept: ~a, " (concept-id c))
  (format t "Definition: ~s."
    (concept-defn c) )
  (format t "~%  Specialization of ~a."
    (concept-id (concept-parent c)))
  (format t
    "~%  Interest: ~7,3f;  ~s examples found out of ~s tried."
    (concept-interest c)
    (concept-number-found c)
    (concept-number-tried c) )
  (format t "~%  Examples found: ~s.~%"
    (concept-examples-found c) ) )

(defun display-task (task)
  "Prints out one agenda task, without any infinite recursion."
  (format t "~% (~7,2f (~S ~S))"
    (first task) (caadr task) (concept-id (cadadr task)) ) )

(defun display-agenda (agenda)
  "Prints out the current agenda of tasks."
  (format t "~%Agenda is: ( " )
  (mapc #'display-task agenda)
  (format t " ) ") )

;-----------------------------------------------------------
;;; TEST exercises the program.
(defun test ()
  "Sets up and executes a run of the program."
  (initialize)         ; Set up initial concept OBJECT etc.
  (setf *reporting* t) ; Display execution details.
  (explore-concepts) ) ; Create and evaluate new concepts.

(test)