;;;; Macintosh Graphical User Interface for OSCAR
;;;; Real time display version .1
;;;; Artilects, LLC DFH
;;;
;;;; first need to set up window
(in-package "OSCAR")
(load "Programming:MCL 3.9:library:quickdraw.lisp")
(require :quickdraw)
(proclaim '(special *move-to-be-made* *node-to-be-moved* *node-radius* *screen-height*
*screen-width* *start-sweep* *end-sweep* *start-i-sweep* *end-i-sweep*
*incf-sweep* *minimum-distance-between-nodes* *maximum-distance-between-nodes*
*last-node-terminal* *last-interest-terminal* *open-position* *og*
*interest-graph* *mes* *speak* *top-line* *show-formulas* *msg*
*supposition-color* *undefeated-node-color* *interest-to-be-moved*
*defeated-node-color* *delay* *inspect-node-dialog* *menu-dialog*
*graphics-initialized* *graphics-on* *graph-log* *nodes-to-be-moved*
*graphics-pause* *nodes-displayed* *nodes-to-graph* *graph-interests*
*interests-to-be-moved* *graph-arguments* *graph-node-arguments*
*move-all-nodes* *move-all-interests* *guide-interest* *monochrome*
*flash-terminal-deductive-ancestors* *strongly-relevant-nodes* *nodes-done*
*terminal-deductive-ancestors* *region-start-position* *selection-region*
*line-color* *back-color* *show-motivators*))
; (use-package "SPEECH")
;(load (merge-pathnames oscar-pathname "SPEECH.LIS"))
;(load (merge-pathnames oscar-pathname "SPEECH-M.LIS"))
(defvar *show-formulas* t)
(defvar *show-motivators* nil)
(defvar *msg* nil)
(defvar *delay* 0)
(defvar *flash-affected-nodes* nil)
(defvar *flash-defeatees* nil)
(defvar *flash-defeaters* nil)
(defvar *flash-ancestors* nil)
(defvar *flash-consequences* nil)
(defvar *flash-support-link-bases* nil)
(defvar *flash-support-links* nil)
(defvar *flash-relevant-nodes* nil)
(defvar *flash-terminal-deductive-ancestors* nil)
(defvar *graph-ancestors* nil)
(defvar *graph-relevant-nodes* nil)
(defvar *menu-dialog* nil)
(defvar *message* nil)
(defvar *nodes-to-graph* nil)
(defvar *graph-interests* nil)
(defvar *nodes-to-be-moved* nil)
(defvar *interests-to-be-moved* nil)
(defvar *graph-arguments* nil)
(defvar *graph-node-arguments* nil)
(defvar *move-all-nodes* nil)
(defvar *move-all-interests* nil)
(defvar *guide-node* nil)
(defvar *guide-interest* nil)
(defvar *monochrome* nil)
(defvar *region-start-position* nil)
(defvar *selection-region* nil)
(defvar *line-color* *white-color*)
(defvar *back-color* *black-color*)
(defun speech-on () (setf *speak* t))
(defun speech-off () (setf *speak* nil))
(defun show-formulas () (setf *show-formulas* t))
(defun do-not-show-formulas () (setf *show-formulas* nil))
(defclass og-window (window)
((node-list :initarg :node-list :initform nil :accessor node-list)
(interest-list :initarg :interest-list :initform nil :accessor interest-list)
(show-formulas-in :initarg :show-formulas-in :initform *show-formulas* :accessor show-formulas-in)
(inf-graph :initform nil :accessor inf-graph)
(int-graph :initform nil :accessor int-graph))
(:default-initargs
:window-type :document-with-grow
:window-title "OSCAR_3.0"
:color-p t
:window-do-first-click t))
(defun make-oscar-window ()
(setf *nodes-displayed* nil)
(when *og* (window-close *og*))
(setf *og* (make-instance 'og-window
:window-title "OSCAR -- Graph of Problem"
:view-position *open-position*
:view-size (make-point *screen-width* *screen-height*)))
(set-part-color *og* :content *back-color*))
(defun flash-nodes (nodes view color times &optional message)
(cond
(nodes
(dotimes (n times)
(let ((colors (mapcar #'(lambda (node) (node-color node view)) nodes)))
(dolist (node nodes)
(draw-just-node (node-position node view) view node color))
(sleep .1)
(mapc #'(lambda (node color)
(draw-just-node (node-position node view) view node color))
nodes colors)
(sleep .1)))
; (invalidate-view view)
)
(message
(let ((mes (make-top-message message)))
(sleep 1)
(window-close mes)))))
(defunction flash-node (number)
(let ((node (node number)))
(dotimes (n 5)
(let ((color (node-color node *og*)))
(draw-just-node (node-position node *og*) *og* node *yellow-color*)
(sleep .1)
(draw-just-node (node-position node *og*) *og* node color)
(sleep .1)))))
(defunction temporarily-color-nodes (nodes)
(setf nodes (remove-if-not #'(lambda (x) (assoc x (node-list *og*))) nodes))
(dolist (node nodes)
(draw-just-node (node-position node *og*) *og* node *yellow-color*))
(pause-graphics)
(invalidate-view *og* t))
;(defmethod view-draw-contents ((wind og-window))
; (dolist (pos (node-list wind))
; (when (not (cancelled-node (car pos)))
; (draw-node (cadr pos) wind (car pos))))
; (dolist (i (interest-list wind))
; (when (not (cancelled-interest (car i)))
; (draw-interest (cdr i) wind (car i)))))
(defmethod view-draw-contents ((wind og-window))
(dolist (pos (node-list wind))
(draw-node (cadr pos) wind (car pos)))
(dolist (i (interest-list wind))
(draw-interest (cdr i) wind (car i))))
(defun ontop (position1 position2)
(< (length-line position1 position2) *node-radius*))
;;;;; Main problem with this port is that we must now keep track of everything drawn
;;;;; to window so that we can redraw using view-draw-contents. Only things to be
;;;;; drawn to window are NODES and SUPPORT-LINKS. The display of a node will
;;;;; automatically draw in support links, e.g. when a node is drawn, so is its support
;;;;; links, so for the present, only NODE positions will be kept track of. Only nodes
;;;;; will be clickable for now, just as in the old version.
;;;;; inference-node positions will be stored in list of dotted pairs, (node number . position),
;;;;; which is the node-list of *og*, the window in which the problem is being graphed
;;;; DRAW-NODE == takes position, view, text and number as arguments
(defun draw-node (position view node)
(draw-just-node position view node (node-color node view))
(draw-support-links position view node)
(attach-discharged-interests position view node)
(draw-arrows-to-generated-direct-reductio-interests position view node)
(attach-arrows-to-defeated-nodes position view node)
(if *show-motivators* (draw-arrows-from-motivating-nodes position view node))
)
(defunction node-color (node view)
(mem2 (e-assoc node (node-list view))))
(defunction node-position (node view)
(mem1 (e-assoc node (node-list view))))
(defunction attach-discharged-interests (position view node)
(when (discharged-interests node)
(dolist (int (mapcar #'car (discharged-interests node)))
(when (interest-p int)
(let ((posi (interest-position int view)))
(when posi
(when (not *monochrome*) (set-fore-color view *purple-color*))
(draw-arrow position posi view)
(when (not *monochrome*) (set-fore-color view *black-color*))))))))
(defunction draw-arrows-to-generated-direct-reductio-interests (position view node)
(when (generated-direct-reductio-interests node)
(dolist (int (generated-direct-reductio-interests node))
(let ((posi (interest-position int view)))
(when posi
(set-fore-color view *orange-color*)
(draw-arrow position posi view)
(set-fore-color view *black-color*))))))
(defunction attach-arrows-to-defeated-nodes (position view node)
(let ((targets nil))
(dolist (slink (node-defeatees node))
(push (support-link-target slink) targets))
(setf targets (remove-duplicates targets))
(dolist (target targets)
(let ((pos-target (node-position target view)))
(when pos-target
(draw-defeat-arrow position pos-target view))))))
(defunction draw-arrows-from-motivating-nodes (position view node)
(dolist (target (motivating-nodes node))
(let ((pos-target (node-position target view)))
(when pos-target
(cond (*monochrome* (set-fore-color view *light-gray-color*))
(t (set-fore-color view *yellow-color*)))
(set-pen-size view #@(4 4))
(draw-arrow pos-target position view)
(set-fore-color view *black-color*)
(set-pen-size view #@(1 1))))))
(defunction draw-support-links (position view node)
; (when (eq node (node 146)) (setf p position v view n node) (break))
;; (step (draw-support-links p v n))
(dolist (sl (support-links node))
(when (defeasible? sl) (set-fore-color view *gray-color*))
(dolist (nb (support-link-basis sl))
(let ((pos-nb (node-position nb view)))
(when pos-nb
(draw-arrow pos-nb position view))))))
(defun draw-undefeated-node (position view node)
(draw-just-undefeated-node position view node)
(draw-support-links position view node)
(attach-discharged-interests position view node)
; (draw-arrows-to-generated-direct-reductio-interests position view node)
(attach-arrows-to-defeated-nodes position view node))
#| The node-list is a list of triples (list node position color). |#
(defun draw-just-node (position view node color)
; (setf p position v view n node c color)
(pull (assoc node (node-list view)) (node-list view))
(push (list node position color) (node-list view))
;;; draw the node itself
(let* ((x (point-h position))
(y (point-v position))
(left (- x *node-radius*))
(top (- y *node-radius*))
(right (+ x *node-radius*))
(bottom (+ y *node-radius*)))
;; clear the space
(erase-oval view left top right bottom)
;; fill it with appropriate color
(cond (*monochrome*
(if (eql (undefeated-degree-of-support node) 0.0)
(set-fore-color view *light-gray-color*)))
(t (set-fore-color view color)))
(when (or (not *monochrome*) (eql (undefeated-degree-of-support node) 0.0))
(paint-oval view left top right bottom))
(set-fore-color view *black-color*)
;; frame it
(cond
((equal view (find-window "Affected-nodes"))
(cond ((not (member node *affected-nodes*))
(set-pen-size view #@(3 3)) (set-fore-color view *brown-color*)
(frame-oval view left top right bottom)
(set-pen-size view #@(1 1)) (set-fore-color view *line-color*))
((answered-queries node)
(set-pen-size view #@(3 3)) (set-fore-color view *red-color*)
(frame-oval view left top right bottom)
(set-pen-size view #@(1 1)) (set-fore-color view *line-color*))
(t (frame-oval view left top right bottom))))
((answered-queries node)
(set-pen-size view #@(3 3))
(when (not *monochrome*) (set-fore-color view *red-color*))
(frame-oval view left top right bottom)
(set-pen-size view #@(1 1)) (set-fore-color view *line-color*))
(t (frame-oval view left top right bottom)))
;;write text
(cond
((< (inference-number node) 10)
(move-to view (- x 2) (+ y 3)))
((< (inference-number node) 100)
(move-to view (- x 5) (+ y 3)))
(t (move-to view (- x 8) (+ y 3))))
(set-fore-color view *black-color*)
(princ (inference-number node) view)
(set-fore-color view *line-color*)
(when (or *show-formulas* (show-formulas-in view))
(move-to view (+ x *node-radius* 3) (+ y 3))
(show-formula node x y view))))
(defunction show-formula (node x y view)
(let* ((formula
(cond
((equal (node-kind node) "percept")
(cat "It appears to me that " (pretty (node-formula node))))
(t (pretty (node-formula node))))))
(princ formula view))
(when (node-supposition node)
(move-to view (+ x *node-radius* 3) (+ y 13))
(princ
(cat-list
(cons " given " (commatize (mapcar #'pretty (node-supposition node))))) view)))
(defunction draw-just-undefeated-node (position view node)
(draw-just-node
position view node
(cond ((node-supposition node) *supposition-color*)
((is-percept node) *yellow-color*)
(t *undefeated-node-color*)))
(draw-support-links position view node)
(attach-discharged-interests position view node)
(draw-arrows-to-generated-direct-reductio-interests position view node)
(attach-arrows-to-defeated-nodes position view node)
(if *show-motivators* (draw-arrows-from-motivating-nodes position view node)))
(defunction draw-just-defeated-node (position view node)
(draw-just-node
position view node
(if (node-supposition node) *light-blue-color* *defeated-node-color*))
(draw-support-links position view node)
(attach-discharged-interests position view node)
(draw-arrows-to-generated-direct-reductio-interests position view node)
(attach-arrows-to-defeated-nodes position view node)
(if *show-motivators* (draw-arrows-from-motivating-nodes position view node)))
(defunction draw-n (node view &optional nodes-displayed)
(cond
((member node nodes-displayed)
(let ((pos (node-position node view)))
(draw-support-links pos view node)
(attach-discharged-interests pos view node)
(draw-arrows-to-generated-direct-reductio-interests pos view node)
(attach-arrows-to-defeated-nodes pos view node)
(if *show-motivators* (draw-arrows-from-motivating-nodes pos view node))))
(t
(let* ((pos (find-position-for-node node view nodes-displayed)))
; (pos
; (if pos1
; (if (or *show-formulas* (show-formulas-in view))
; (adjust-again (adjust-for-text pos1)) pos1) nil)))
(when pos
(draw-undefeated-node pos view node)))))
(announce-node node))
(defunction announce-node (node)
(when (and (boundp '*speak*) *speak*)
(sleep .5)
(cond
((equal (node-justification node) :given)
(speak-text
(cat "I am given that "
(pranc-to-string (pretty (node-formula node))))))
((equal (node-kind node) :percept)
(speak-text
(cat-list (list "It appears to me that "
(pranc-to-string (pretty (node-formula node)))
" by perceptual input"))))
((equal (node-justification node) :supposition)
(speak-text
(cat "Let us suppose that "
(pranc-to-string (pretty (node-formula node))))))
((equal (node-justification node) :reductio-supposition)
(speak-text
(cat "Let us suppose that "
(pranc-to-string (pretty (node-formula node))))))
((some #'(lambda (L) (null (support-link-basis L))) (support-links node))
(speak-text
(cat "It is true a priori that "
(pranc-to-string (pretty (node-formula node))))))
(t (let
((msg
(list
(if (some #'defeasible? (support-links node))
"It follows defeasibly that "
"It follows that ")
(pranc-to-string (pretty (node-formula node))))))
(when (node-supposition node)
(setf msg
(append
msg
(list
"given the supposition that"
(pranc-to-string (pretty (gen-conjunction (node-supposition node))))))))
(speak-text (cat-list msg)))
; (dolist (x (support-links node))
; (when (or (null *nodes-displayed*) (subsetp (support-link-basis x) *nodes-displayed*))
; (speak-text (cat "by " (pranc-to-string (princ-to-string (support-link-rule x)))))))
))))
;;;; DRAWING ROUTINES FOR INTERESTS
(defun draw-i (interest view)
(let ((pos (find-position-for-interest interest view)))
(cond
(pos
(draw-interest pos view interest)
(push (cons interest pos) (interest-list view)))
(t nil)))
(announce-interest interest))
(defunction announce-interest (interest)
(when (and (boundp '*speak*) *speak*)
(sleep .5)
(speak-text (cat "I adopt interest " (princ-to-string (interest-number interest))))
(speak-text (pranc-to-string (pretty (interest-formula interest))))
(cond
((interest-defeatees interest)
(speak-text (cat "because it is a potential defeater for support links of node "
(princ-to-string
(mapcar #'inference-number
(mapcar #'support-link-target (interest-defeatees interest)))))))
(t nil))))
(defunction interest-position (interest view)
(e-assoc interest (interest-list view)))
(defun draw-interest (position view node)
; (setf p position v view n node)
;; (step (draw-interest p v n))
(draw-just-interest position view node)
;; draw arrows
(dolist (drl (right-links node))
(let* ((int (resultant-interest drl))
(pos (if (interest-p int) (interest-position int view))))
(if pos (draw-arrow pos position view))))
;;; draw arrows to generated suppositions
(dolist (nod (generated-suppositions node))
(let ((posi (node-position nod view)))
(when posi
(when (not *monochrome*) (set-fore-color view *blue-color*))
(draw-arrow position posi view)
(set-fore-color view *line-color*))))
;;; draw arrows to generating nodes ;; orange if reductio interest
; (dolist (nod (mapcar #'support-link-target (interest-defeatees node)))
; (let ((posi (node-position nod view)))
; (when posi
; (set-fore-color view (if (reductio-interest node) *orange-color* *yellow-color*))
; (draw-arrow posi position view)
; (set-fore-color view *line-color*))))
)
(defun draw-just-interest (position view node)
;;; draw the node itself
(let* ((x (point-h position))
(y (point-v position))
(left (- x *node-radius*))
(top (- y *node-radius*))
(right (+ x *node-radius*))
(bottom (+ y *node-radius*))
(wincolor
(if (some #'(lambda (L) (equal (link-rule L) "answer")) (right-links node))
3538753 9405695)))
;; clear the space
(erase-oval view left top right bottom)
(when (not *monochrome*)
;; fill it with appropriate color
(set-fore-color view wincolor)
(paint-oval view left top right bottom)
(set-fore-color view *line-color*))
;; frame it and write text
(frame-oval view left top right bottom)
(cond
((< (interest-number node) 10)
(move-to view (- x 2) (+ y 3)))
((< (interest-number node) 100)
(move-to view (- x 5) (+ y 3)))
(t (move-to view (- x 8) (+ y 3))))
(set-fore-color view *black-color*)
(princ (interest-number node) view)
(set-fore-color view *line-color*)
(when (or *show-formulas* (show-formulas-in view))
(move-to view (+ x *node-radius* 3) (+ y 3))
(show-i-formula node x y view))))
(defunction show-i-formula (interest x y view)
(princ (pretty (interest-formula interest)) view)
(when (interest-supposition interest)
(move-to view (+ x *node-radius* 3) (+ y 13))
(princ
(cat-list
(cons " given " (commatize (mapcar #'pretty (interest-supposition interest))))) view)))
(defunction find-position-for-interest (int view)
; (setf i int v view) (break)
;; (step (find-position-for-interest i v))
;;; if it has been drawn already, return nil (for now)
(cond
((assoc int (interest-list view)) nil)
;;;; if it has no support links, or it is a query interest, figure out where to put it
;;;; using a slide along the bottom algorithm
((or (null (right-links int))
(some #'(lambda (L) (equal (link-rule L) "answer")) (right-links int)))
(let* ((condition
(< (point-h *last-interest-terminal*)
(- *screen-width* *minimum-distance-between-nodes*)))
(h-pos (if condition
(+ (point-h *last-interest-terminal*) *minimum-distance-between-nodes*)
(round (/ *screen-width* 2))))
(v-pos (if condition
(point-v *last-interest-terminal*)
(- (point-v *last-interest-terminal*) *minimum-distance-between-nodes*))))
(loop
(if (good-position h-pos v-pos view) (return (make-point h-pos v-pos)))
(cond ((< h-pos (- *screen-width* *minimum-distance-between-nodes*))
(setf h-pos (+ h-pos *minimum-distance-between-nodes*)))
(t
(setf h-pos (round (/ *screen-width* 100)))
(setf v-pos (- v-pos *minimum-distance-between-nodes*)))))))
;;;; if it has support-links, then figure it out by the position of its support links
(t
(let* ((sweep *start-i-sweep*)
(longth *minimum-distance-between-nodes*)
(suppos
(if (right-links int)
(interest-position (resultant-interest (first (last (right-links int)))) view)))
(h (if suppos (adjusted-h-position (point-h suppos) int) 50))
(v (if suppos (i-adjusted-v-position (point-v suppos) int) 450))
(h-pos (+ h (round (* longth (cosd sweep)))))
(v-pos (- v (round (* longth (sind sweep))))))
(loop
(if (good-position h-pos v-pos view) (return (make-point h-pos v-pos)))
(cond ((<= sweep *end-i-sweep*)
(setf sweep *start-i-sweep*)
(setf longth (+ longth 10))
(setf h-pos (+ h (round (* longth (cosd sweep)))))
(setf v-pos (- v (round (* longth (sind sweep))))))
(t (setf sweep (- sweep 30))
(setf h-pos (+ h (round (* longth (cosd sweep)))))
(setf v-pos (- v (round (* longth (sind sweep))))))))))))
(defunction i-adjusted-v-position (x int)
(- x (expt (rem (+ 2 (interest-number int)) 5) 2)))
;;;; ;; FIND-POSITION-FOR-NODE This function finds a place for the new node, inserts it into
;;;; ; the list of positions, and calls view-draw-contents to make sure that the entire
;;;;; window is updated.
;;;; first some basic geometry -- degrees to radians
(defun dtr (degrees)
(/ degrees 57.2))
(defun sind (degrees)
(sin (dtr degrees)))
(defun cosd (degrees)
(cos (dtr degrees)))
(defunction find-position-for-node (node view &optional nodes-displayed)
; (setf n node v view nd nodes-displayed)
;; (step (find-position-for-node n v nd))
;;; if it has been drawn already, return nil (for now)
(cond
((assoc node (node-list view)) nil)
;;;; if it has no support links, figure out where to put it using a slide along the top algorithm
((or (null (support-links node)) (null nodes-displayed)
(every
#'(lambda (L)
(or (null (support-link-basis L))
(not (subsetp (support-link-basis L) nodes-displayed))))
(support-links node)))
(let* ((condition
(< (point-h *last-node-terminal*)
(- *screen-width* *minimum-distance-between-nodes*)))
(h-pos (if condition
(+ (point-h *last-node-terminal*) *minimum-distance-between-nodes*)
(round (/ *screen-width* 100))))
(v-pos (if condition
(point-v *last-node-terminal*)
(+ (point-v *last-node-terminal*) *minimum-distance-between-nodes*))))
(loop
(if (good-position h-pos v-pos view) (return (make-point h-pos v-pos)))
(cond ((< h-pos (- *screen-width* *minimum-distance-between-nodes*))
(setf h-pos (+ h-pos *minimum-distance-between-nodes*)))
(t
(setf h-pos (round (/ *screen-width* 100)))
(setf v-pos (+ v-pos *minimum-distance-between-nodes*)))))))
;;;; if it has support-links, then figure it out by the position of its support links
(t
(let* ((sweep *start-sweep*)
(longth *minimum-distance-between-nodes*)
(suppos (node-position (first (support-link-basis (first (last (support-links node))))) view))
(h (adjusted-h-position (point-h suppos) node))
(v (adjusted-v-position (point-v suppos) node))
(h-pos (+ h (round (* longth (cosd sweep)))))
(v-pos (- v (round (* longth (sind sweep))))))
(loop
(if (good-position h-pos v-pos view) (return (make-point h-pos v-pos)))
(cond ((>= sweep *end-sweep*)
(setf sweep *start-sweep*)
(setf longth (+ longth 10))
(setf h-pos (+ h (round (* longth (cosd sweep)))))
(setf v-pos (- v (round (* longth (sind sweep))))))
(t (setf sweep (+ sweep 30))
(setf h-pos (+ h (round (* longth (cosd sweep)))))
(setf v-pos (- v (round (* longth (sind sweep))))))))))))
(defunction adjusted-h-position (x node)
(+ x (expt (rem (inference-number node) 5) 2)))
(defunction adjusted-v-position (x node)
(+ x (expt (rem (+ 2 (inference-number node)) 5) 2)))
;;; GOODPOSITION -- This function simply checks to make sure that the position
;;; isn't on top of anything in the node-list and that it is within the bounds of the screen
(defunction good-position (h-pos v-pos view)
(and (>= h-pos *node-radius*) (> v-pos 15)
(<= v-pos (- *screen-height* *node-radius*))
(<= h-pos (- *screen-width* *node-radius*))
(every #'(lambda (item) (away-from h-pos v-pos (cadr item))) (node-list view))
(every #'(lambda (item) (away-from h-pos v-pos (cdr item))) (interest-list view))))
(defunction away-from (h-pos v-pos place)
(let* ((h-diff (- h-pos (point-h place)))
(v-diff (- v-pos (point-v place)))
(distance (sqrt (+ (expt h-diff 2) (expt v-diff 2)))))
(< (- *minimum-distance-between-nodes* 5) distance)))
(defun length-line (position1 position2)
(let ((diffvector (subtract-points position1 position2)))
(sqrt (+ (expt (point-h diffvector) 2) (expt (point-v diffvector) 2)))))
;;; a little trigonometry
(defun point-to-line (end1 end2 point1)
(let* ((a (length-line point1 end1))
(b (length-line point1 end2))
(c (length-line end1 end2))
(s (/ (+ a b c) 2))
(sina (/ (* 2 (sqrt (* s (- s a) (- s b) (- s c)))) (* b c))))
(* sina b)))
;;; this takes a position, scans to see if any nodes are to the left of it, and
;;; moves it up or down appropriately
(defun adjust-for-text (pos)
(let ((left-side (- (point-h pos) (* 1 *minimum-distance-between-nodes*)))
(top-side (- (point-v pos) (round (* .5 *node-radius*))))
(right-side (point-h pos))
(bottom-side (+ (point-v pos) (round (* .5 *node-radius*))))
(violator nil))
(if (some #'(lambda (p)
(setf violator (cadr p))
(point-in-box left-side top-side right-side bottom-side (cadr p)))
(node-list *og*))
(cond ((< (point-v pos) 20) (make-point (point-h pos) (+ (point-v pos) (* 2 *node-radius*))))
(t (make-point (point-h pos) (+ (point-v pos) (round (* 1.2 *node-radius*))))))
pos)))
(defun adjust-for-text-i (pos)
(let ((left-side (- (point-h pos) (* 1 *minimum-distance-between-nodes*)))
(top-side (- (point-v pos) (round (* .5 *node-radius*))))
(right-side (point-h pos))
(bottom-side (+ (point-v pos) (round (* .5 *node-radius*))))
(violator nil))
(if (some #'(lambda (p) (setf violator (cdr p))
(point-in-box left-side top-side right-side bottom-side (cdr p)))
(interest-list *og*))
(cond ((< (point-v pos) 20) (make-point (point-h pos) (- (point-v pos) (* 2 *node-radius*))))
((< (point-v pos) (point-v violator)) (make-point (point-h pos) (+ (point-v pos) (* 1 *node-radius*))))
(t (make-point (point-h pos) (- (point-v pos) (round (* 1.5 *node-radius*))))))
pos)))
(defun point-in-box (left top right bottom point)
(let ((h (point-h point))
(v (point-v point)))
(and
(<= h right) (>= h left) (>= v top) (<= v bottom))))
;;;; now a function that returns t if the hypothetical position for a node will not result in drawing
;;;; lines through any other nodes
(defun draw-arrow (position1 position2 view)
(let* ((lbn (length-line position1 position2))
(xpos (round (/ (* *node-radius* (- (point-h position2) (point-h position1))) lbn)))
(ypos (round (/ (* *node-radius* (- (point-v position2) (point-v position1))) lbn)))
(l (sqrt (+ (expt xpos 2) (expt ypos 2))))
(destpos (make-point (- (point-h position2) xpos) (- (point-v position2) ypos)))
(angle-off (+ (acos (/ (* (if (< (point-v position2) (point-v position1)) 1 -1) xpos) l))
(if (< (point-v position2) (point-v position1)) (dtr 180) 0)))
(point-low (make-point (+ (point-h destpos) (round (* l .5 (cos (- angle-off (dtr 30))))))
(- (point-v destpos) (round (* l .5 (sin (- angle-off (dtr 30))))))))
(point-high (make-point (+ (point-h destpos) (round (* l .5 (cos (+ angle-off (dtr 30))))))
(- (point-v destpos) (round (* l .5 (sin (+ angle-off (dtr 30)))))))))
(move-to view position1)
(move view xpos ypos)
(line-to view destpos)
(line-to view point-low)
(move-to view destpos)
(line-to view point-high)))
(defun draw-defeat-arrow (position1 position2 view)
(let ((pp (pen-size view)))
(cond (*monochrome*
(set-fore-color view *light-gray-color*)
(set-pen-size view #@(3 3)))
(t (set-fore-color view *red-color*)))
(draw-arrow position1 position2 view)
(set-fore-color view *line-color*)
(set-pen-size view pp)))
(defun pranc-to-string (astring)
(let* ((lstr (read-from-string (concatenate 'string "(" astring ")")))
(nstr
(sublis
'((~ . not) (v . or) (-> . implies) (<-> . "if and only if")
(@ "does not guarantee that ")
(x0 "a person") ;; temporary
(disj-simp "disjunctive simplification") (modus-ponens1 "modus ponens")
(modus-tollens1 "modus tollens") (modus-tollens2 "modus tollens")
(i-neg-condit "introduction of negated conditional")
(neg-condit "conditional negation")
(i-neg-disj "introduction of negated disjunction")
(neg-disj "disjunction negation")
(disj-cond-2 "transformation of conditionals to disjunctions")
(UI "universal instantiation")
(EI "existential instantiation")
(UG "universal generalization")
(EG "existential generalization")
(i-DM "DeMorgan's laws")
(DM "DeMorgan's laws")
(modus-ponens1 "modus ponens")
(modus-ponens2 "modus ponens")
(*perception* "perception")
(*indexical-perception* "indexical-perception")
(*indexical-perceptual-reliability* "indexical-perceptual-reliability")
(*perceptual-reliability* "perceptual-reliability")
(*perception-update-from-competing-percept* "perception-update-from-competing-percept")
(*defeat-for-perception-update-from-competing-percept*
"defeat-for-perception-update-from-competing-percept")
(*temporal-projection* "temporal-projection")
(*causal-undercutter+* "causal-undercutter")
(*causal-undercutter* "causal-undercutter")
(*causal-implication* "causal-implication")
(strict-arithmetical-inequality "arithmetic")
(arithmetical-inequality "arithmetic")
(Tucson "Two son")
(Maria "Ma riia")
) lstr)))
(princ-to-string nstr)))
(defun graph-problem (&key full)
(if *og* (window-close *og*))
(setf *og* (make-instance 'og-window
:window-title "OSCAR -- Graph of Problem"
:view-position *open-position*
:view-size (make-point *screen-width* *screen-height* )))
(set-part-color *og* :content *back-color*)
; (set-back-color *og* *back-color*)
;;;; set up somewhat simplified version of interest graph, for display purposes will skip display
;;;; of interests with different suppositions but same formulas
;;;; announce problem
(when (and (boundp '*speak*) *speak*)
(speak-text "I am Oscar.")
(cond
(*msg* (speak-text *msg*))
((boundp '*problem-number*)
(speak-text (cat "I will now solve problem number " (princ-to-string *problem-number*)))
(if (or *forwards-substantive-reasons* *backwards-substantive-reasons*)
(speak-text " using both logic and the substantive reasons provided to me...")
(speak-text " using logic..."))))
(sleep 1))
;;;;; draw stuff
(let ((nodes nil))
(dolist (query *ultimate-epistemic-interests*)
(dolist (N (query-answers query)) (pushnew N nodes)))
(let* ((proof-nodes (if full nil *relevant-nodes*))
(ultimate-interests (mapcar #'query-interest *ultimate-epistemic-interests*))
(enabling-interests
(unionmapcar+ #'enabling-interests proof-nodes))
(closure (generated-nodes-and-interests
proof-nodes (union ultimate-interests enabling-interests) ultimate-interests))
(nodes-used (mem1 closure))
(interests-used (mem2 closure))
(reasoning-log nil)
(nodes-displayed nil))
(if full
(setf reasoning-log (reverse *reasoning-log*))
(dolist (x *reasoning-log*)
(cond
((inference-node-p x) (if (member x nodes-used) (push x reasoning-log)))
((interest-p x) (if (member x interests-used) (push x reasoning-log)))
(t (push x reasoning-log)))))
(let ((last-entry nil))
(dolist (x reasoning-log)
(if (and (boundp '*speak*) *speak*) (sleep 1) (sleep *delay*))
(cond
((inference-node-p x) (draw-n x *og* nodes-displayed)
(push x nodes-displayed) (setf last-entry x))
((interest-p x) (if *graph-interests* (draw-i x *og*)) (setf last-entry x))
((listp x)
;;; recolor node / will blink in event that stays same color
(cond ((and (equal (mem1 x) :increased-support)
(or full (member (mem2 x) nodes-used)))
(let* ((nod (mem2 x))
(posi (node-position nod *og*)))
(when posi
(draw-just-undefeated-node posi *og* nod)))
(when (and (boundp '*speak*) *speak*)
(speak-text "The undefeeted-degree-of-support of node ")
(speak-text (write-to-string (inference-number (mem2 x))))
(speak-text "has increased to")
(speak-text (write-to-string (undefeated-degree-of-support (mem2 x))))))
((and (equal (mem1 x) :defeated) (or full (member (mem2 x) nodes-used)))
;; recolor node
(let* ((nod (mem2 x))
(posi (node-position nod *og*)))
(when posi
(draw-just-defeated-node posi *og* nod)))
(when (and (boundp '*speak*) *speak*)
(speak-text "Node ")
(speak-text (write-to-string (inference-number (mem2 x))))
(if (equal (mem2 x) last-entry)
(speak-text "is defeated.")
(speak-text "has become defeated."))))
((and (equal (mem1 x) :decreased-support) (or full (member (mem2 x) nodes-used)))
(when (and (boundp '*speak*) *speak*)
(speak-text "The undefeeted-degree-of-support of node ")
(speak-text (write-to-string (inference-number (mem2 x))))
(speak-text "has decreased to")
(speak-text (write-to-string (undefeated-degree-of-support (mem2 x))))))
((and (equal (mem1 x) :answer-query) (or full (member (mem2 x) nodes-used)))
(when (and (boundp '*speak*) *speak*)
(speak-text "Node ")
(speak-text (write-to-string (inference-number (mem2 x))))
(speak-text "answers query ")
(speak-text (write-to-string (query-number (mem3 x))))))
)))))
(when (and (boundp '*speak*) *speak*)
(setf nodes
(subset
#'(lambda (n)
(some #'(lambda (q) (>= (undefeated-degree-of-support n) (query-strength q)))
(answered-queries n)))
nodes))
(when nodes
(speak-text
(cond
((cdr nodes)
(cat-list
(list "In conclusion, " (pranc-to-string (princ-to-string (node-formula (car nodes))))
(mapcar #'(lambda (n) (cat ", " (pranc-to-string (princ-to-string (node-formula n)))))
(cdr nodes)))))
(t (cat "In conclusion, " (pranc-to-string (princ-to-string (node-formula (car nodes))))))))))
(invalidate-view *og*))))
(defunction adjust-again (pos)
(make-point (point-h pos)
(+ (point-v pos) (round (/ (* (point-h pos) .3 *node-radius*)
*minimum-distance-between-nodes*)))))
(defunction adjust-again-i (pos)
(make-point (point-h pos)
(- (point-v pos) (round (/ (* (point-h pos) .3 *node-radius*)
*minimum-distance-between-nodes*)))))
(defunction graph-nodes (nodes window &optional (title"OSCAR -- Graph of Nodes" ) show-formulas)
(let ((wind (find-window title)))
(when wind (window-close wind)))
(let ((view (make-instance 'og-window
:window-title title
:view-position *open-position*
:view-size (make-point *screen-width* *screen-height*)
:show-formulas-in show-formulas)))
(set-part-color view :content *back-color*)
(setf (node-list view) (subset #'(lambda (x) (member (car x) nodes)) (node-list window)))
(invalidate-view view)))
(defunction graph-affected-nodes (view)
(graph-nodes
(union *affected-nodes*
(unionmapcar+
#'(lambda (N) (unionmapcar+ #'support-link-basis (support-links N)))
*affected-nodes*))
view)
"Affected-nodes")
#| Nodes can be a single node or a list of nodes. |#
(defunction graph-ancestors (nodes view)
(when (not (listp nodes)) (setf nodes (list nodes)))
(graph-nodes
(union nodes (unionmapcar+ #'node-ancestors nodes))
view
(cat-list
(append (list "Node-ancestors for node" (if (cdr nodes) "s " " "))
(commatize
(mapcar #'(lambda (n) (write-to-string (inference-number n))) nodes))))))
#| Nodes can be a single node or a list of nodes. If nodes is empty, nodes relevant
to all query-answers are graphed. |#
(defunction graph-relevant-nodes (view &optional nodes)
(when (null nodes)
(dolist (query *ultimate-epistemic-interests*)
(dolist (N (query-answers query))
(pushnew N nodes))))
(when (not (listp nodes)) (setf nodes (list nodes)))
(let ((rn *relevant-nodes*))
(compute-relevant-nodes nodes)
(graph-nodes
*relevant-nodes* view
(cat-list
(append (list "Nodes relevant to node" (if (cdr nodes) "s " " "))
(commatize
(mapcar #'(lambda (n) (write-to-string (inference-number n))) nodes)))))
(setf *relevant-nodes* rn))
nil)
#| Insert commas between the members of the list strings |#
(defunction commatize (strings)
(let ((new-strings (list (car strings))))
(loop
(setf strings (cdr strings))
(when (null strings) (return (reverse new-strings)))
(push " , " new-strings)
(push (car strings) new-strings))))
(defun initialize-graphics ()
(setf *move-to-be-made* nil)
(setf *msg* nil)
(setf *inspect-node-dialog* nil)
(setf *node-to-be-moved* nil)
(setf *node-radius* 10)
(setf *start-sweep* 210)
(setf *end-sweep* 330)
(setf *show-formulas* nil)
(setf *start-i-sweep* 120)
(setf *end-i-sweep* 30)
(setf *incf-sweep* 10)
(setf *minimum-distance-between-nodes* 40)
(setf *maximum-distance-between-nodes* 600)
(setf *last-node-terminal* (make-point -20 20))
(setf *top-line* 20)
(setf *last-interest-terminal* (make-point -20 (- *screen-height* 15)))
(setf *open-position* #@(100 100))
(setf *supposition-color* 16716008)
(setf *undefeated-node-color* 16732939)
(setf *defeated-node-color* 16750228)
(size-OSCAR-graphics-window)
(setf *graphics-initialized* t)
(setf *graphics-on* nil)
(add-graphics-menu-items)
(add-nodes-menu)
)
(defunction size-OSCAR-graphics-window ()
(setf *og*
(make-instance 'dialog
:window-type
:document-with-zoom
:window-title
"Position OSCAR Graphics Window"
:view-position
2686978
:view-size
#@(632 459)
:view-font
'("Chicago" 12 :srcor :plain)
:view-subviews
(list (make-dialog-item
'static-text-dialog-item
#@(32 16)
#@(235 49)
"Position and size this window to
adjust the position and size of the
OSCAR graphics window."
'nil)
(make-dialog-item
'button-dialog-item
#@(128 77)
#@(39 22)
"OK"
#'(lambda (item)
(declare (ignore item))
(setf *open-position* (view-position *og*))
(setf *screen-height* (point-v (view-size *og*)))
(setf *screen-width* (point-h (view-size *og*)))
(window-close *og*))
:default-button t)))))
(defunction add-graphics-menu-items ()
(let* ((menubar (menubar))
(oscar-item
(find-if #'(lambda (item) (equal (menu-title item) "GRAPHICS")) menubar)))
(set-menubar
(append
(remove oscar-item menubar)
(list
(make-instance 'menu
:menu-title
"GRAPHICS"
:menu-items
(list
(make-instance 'menu-item
:menu-item-title "Graph reasoning"
:menu-item-action
#'(lambda nil
(menu-item-disable (oscar-graphics-menu-item "Graph reasoning"))
(menu-item-enable (oscar-graphics-menu-item "Do not graph reasoning"))
(setf *graphics-on* t))
:disabled *graphics-on*)
(make-instance 'menu-item
:menu-item-title "Do not graph reasoning"
:menu-item-action
#'(lambda nil
(menu-item-disable (oscar-graphics-menu-item "Do not graph reasoning"))
(menu-item-enable (oscar-graphics-menu-item "Graph reasoning"))
(setf *graphics-on* nil))
:disabled (not *graphics-on*))
(make-instance 'menu-item :menu-item-title "-" :disabled t)
(make-instance 'menu-item
:menu-item-title "Graph reasoning-log"
:menu-item-action
#'(lambda nil
(menu-item-disable (oscar-graphics-menu-item "Graph reasoning-log"))
(menu-item-enable (oscar-graphics-menu-item "Do not graph reasoning-log"))
(setf *graph-log* t))
:disabled *graph-log*)
(make-instance 'menu-item
:menu-item-title "Do not graph reasoning-log"
:menu-item-action
#'(lambda nil
(menu-item-disable (oscar-graphics-menu-item "Do not graph reasoning-log"))
(menu-item-enable (oscar-graphics-menu-item "Graph reasoning-log"))
(setf *graph-log* nil))
:disabled (not *graph-log*))
(make-instance 'menu-item :menu-item-title "-" :disabled t)
(make-instance 'menu-item
:menu-item-title "Graph problem"
:menu-item-action #'(lambda nil (eval-enqueue '(graph-problem))))
(make-instance 'menu-item
:menu-item-title "Graph problem completely"
:menu-item-action #'(lambda nil (eval-enqueue '(graph-problem :full t))))
(make-instance 'menu-item
:menu-item-title "Abbreviated graph"
:menu-item-action
#'(lambda nil (eval-enqueue '(draw-abbreviated-display (front-window :class 'og-window)))))
(make-instance 'menu-item :menu-item-title "-" :disabled t)
(make-instance 'menu-item
:menu-item-title "Pause on"
:menu-item-action
#'(lambda nil
(menu-item-disable (oscar-graphics-menu-item "Pause on"))
(menu-item-enable (oscar-graphics-menu-item "Pause off"))
(setf *graphics-pause* t))
:disabled *graphics-pause*)
(make-instance 'menu-item
:menu-item-title "Pause off"
:menu-item-action
#'(lambda nil
(menu-item-disable (oscar-graphics-menu-item "Pause off"))
(menu-item-enable (oscar-graphics-menu-item "Pause on"))
(setf *graphics-pause* nil))
:disabled (not *graphics-pause*))
(make-instance 'menu-item :menu-item-title "-" :disabled t)
(make-instance 'menu-item
:menu-item-title "Speech on"
:menu-item-action
#'(lambda nil
(menu-item-disable (oscar-graphics-menu-item "Speech on"))
(menu-item-enable (oscar-graphics-menu-item "Speech off"))
(get-default-speech-channel-from-user) (setf *speak* t))
:disabled (and (boundp '*speak*) *speak*))
(make-instance 'menu-item
:menu-item-title "Speech off"
:menu-item-action
#'(lambda nil
(menu-item-disable (oscar-graphics-menu-item "Speech off"))
(menu-item-enable (oscar-graphics-menu-item "Speech on"))
(setf *speak* nil))
:disabled (not (and (boundp '*speak*) *speak*)))
(make-instance 'menu-item :menu-item-title "-" :disabled t)
(make-instance 'menu-item
:menu-item-title "Graph interests"
:menu-item-action
#'(lambda nil
(menu-item-disable (oscar-graphics-menu-item "Graph interests"))
(menu-item-enable (oscar-graphics-menu-item "Do not graph interests"))
(setf *graph-interests* t))
:disabled *graph-interests*)
(make-instance 'menu-item
:menu-item-title "Do not graph interests"
:menu-item-action
#'(lambda nil
(menu-item-disable (oscar-graphics-menu-item "Do not graph interests"))
(menu-item-enable (oscar-graphics-menu-item "Graph interests"))
(setf *graph-interests* nil))
:disabled (not *graph-interests*))
(make-instance 'menu-item :menu-item-title "-" :disabled t)
(make-instance 'menu-item
:menu-item-title "Show formulas"
:menu-item-action
#'(lambda nil
(menu-item-enable (oscar-graphics-menu-item "Do not show formulas"))
(let ((window (front-window)))
(cond ((typep window 'og-window)
(setf (show-formulas-in window) t)
(invalidate-view window t))
(t
(setf *show-formulas* t)
; (menu-item-disable (oscar-graphics-menu-item "Show formulas"))
; (menu-item-enable (oscar-graphics-menu-item "Do not show formulas"))
))))
; :disabled *show-formulas*
)
(make-instance 'menu-item
:menu-item-title "Do not show formulas"
:menu-item-action
#'(lambda nil
(let ((window (front-window)))
(cond ((typep window 'og-window)
(setf (show-formulas-in window) nil)
(invalidate-view window t))
(t (setf *show-formulas* nil)
; (menu-item-disable (oscar-graphics-menu-item "Do not show formulas"))
; (menu-item-enable (oscar-graphics-menu-item "Show formulas"))
))))
;:disabled (not *show-formulas*)
)
(make-instance 'menu-item :menu-item-title "-" :disabled t)
(make-instance 'menu-item
:menu-item-title "Node-radius"
:menu-item-action
#'(lambda nil
(setf *menu-dialog*
(make-instance 'dialog
:window-type :double-edge-box
:view-position #@(60 51)
:view-size #@(222 98)
:close-box-p nil
:view-font '("Chicago" 12 :srcor :plain)
:view-subviews
(list
(make-dialog-item
'static-text-dialog-item #@(22 15) #@(177 34)
"Enter the node-radius and type a carriage-return."
'nil
:text-justification :center)
(make-dialog-item
'editable-text-dialog-item #@(86 64) #@(48 16)
(write-to-string *node-radius*)
#'(lambda (item)
(let ((text (dialog-item-text item)))
(when (and (> (length text) 0)
(equal (substring text (1- (length text))) "
"))
(setf *node-radius* (read-from-string text))
(window-close *menu-dialog*))))
:allow-returns t))))))
(make-instance 'menu-item
:menu-item-title "Minimum-distance-between-nodes"
:menu-item-action
#'(lambda nil
(setf *menu-dialog*
(make-instance 'dialog
:window-type :double-edge-box
:view-position #@(60 51)
:view-size #@(251 116)
:close-box-p nil
:view-font '("Chicago" 12 :srcor :plain)
:view-subviews
(list
(make-dialog-item
'static-text-dialog-item #@(9 12) #@(240 54)
"Enter the minimum-distance-between-nodes and type a carriage-return."
'nil)
(make-dialog-item
'editable-text-dialog-item #@(99 74) #@(48 16)
(write-to-string *minimum-distance-between-nodes*)
#'(lambda (item)
(let ((text (dialog-item-text item)))
(when (and (> (length text) 0)
(equal (substring text (1- (length text))) "
"))
(setf *minimum-distance-between-nodes*
(read-from-string text))
(window-close *menu-dialog*))))
:allow-returns t))))))
(make-instance 'menu-item :menu-item-title "-" :disabled t)
(make-instance 'menu-item
:menu-item-title "Color with black background"
:menu-item-action
#'(lambda nil
(let ((view (front-window :class 'og-window)))
(menu-item-disable (oscar-graphics-menu-item "Color with black background"))
(menu-item-enable (oscar-graphics-menu-item "Color with white background"))
(menu-item-enable (oscar-graphics-menu-item "Monochrome"))
(setf *monochrome* nil)
(setf *back-color* *black-color*)
(set-back-color view *back-color*)
(setf *line-color* *white-color*)
(invalidate-view view t)))
:disabled (and (not *monochrome*) (equal *back-color* *black-color*)))
(make-instance 'menu-item
:menu-item-title "Color with white background"
:menu-item-action
#'(lambda nil
(let ((view (front-window :class 'og-window)))
(menu-item-disable (oscar-graphics-menu-item "Color with white background"))
(menu-item-enable (oscar-graphics-menu-item "Color with black background"))
(menu-item-enable (oscar-graphics-menu-item "Monochrome"))
(setf *monochrome* nil)
(setf *back-color* *white-color*)
(set-back-color view *back-color*)
(setf *line-color* *black-color*)
(invalidate-view view t)))
:disabled (and (not *monochrome*) (equal *back-color* *white-color*)))
(make-instance 'menu-item
:menu-item-title "Monochrome"
:menu-item-action
#'(lambda nil
(let ((view (front-window :class 'og-window)))
(menu-item-disable (oscar-graphics-menu-item "Monochrome"))
(menu-item-enable (oscar-graphics-menu-item "Color with black background"))
(menu-item-enable (oscar-graphics-menu-item "Color with white background"))
(setf *monochrome* t)
(setf *back-color* *white-color*)
(set-back-color view *white-color*)
(setf *line-color* *black-color*)
(invalidate-view view t)))
:disabled *monochrome*)
(make-instance 'menu-item :menu-item-title "-" :disabled t)
(make-instance 'menu-item
:menu-item-title "Refresh Window"
:menu-item-action
#'(lambda nil (invalidate-view (front-window :class 'og-window) t)))
(make-instance 'menu-item
:menu-item-title "Resize Window"
:menu-item-action
#'(lambda nil (size-OSCAR-graphics-window))))))))))
(defunction oscar-graphics-menu-item (string)
(let ((oscar-menu
(find-if #'(lambda (item) (equal (menu-title item) "GRAPHICS")) (menubar))))
(find-if #'(lambda (item) (equal (menu-title item) string)) (menu-items oscar-menu))))
(defunction add-nodes-menu ()
(let ((menubar (menubar)))
(set-menubar
(append
(remove
(find-if #'(lambda (item) (equal (menu-title item) "NODES")) menubar)
menubar)
(list
(make-instance 'menu
:menu-title "NODES"
:menu-items
(list
(make-instance 'menu-item
:menu-item-title "Flash Nodes:"
:style :underline
:menu-item-action #'(lambda nil))
(make-instance 'menu-item
:menu-item-title " Node"
:menu-item-action #'(lambda nil (flash-queried-node)))
(make-instance 'menu-item
:menu-item-title " Support-link"
:menu-item-action #'(lambda nil (flash-queried-support-link)))
(make-instance 'menu-item
:menu-item-title " ......"
:menu-item-action #'(lambda nil))
(make-instance 'menu-item
:menu-item-title " Affected-nodes"
:menu-item-action #'(lambda nil (setf *flash-affected-nodes* t)))
(make-instance 'menu-item
:menu-item-title " Ancestors"
:menu-item-action #'(lambda nil (setf *flash-ancestors* t)))
(make-instance 'menu-item
:menu-item-title " Consequences"
:menu-item-action #'(lambda nil (setf *flash-consequences* t)))
(make-instance 'menu-item
:menu-item-title " Defeatees"
:menu-item-action #'(lambda nil (setf *flash-defeatees* t)))
(make-instance 'menu-item
:menu-item-title " Defeaters"
:menu-item-action #'(lambda nil (setf *flash-defeaters* t)))
(make-instance 'menu-item
:menu-item-title " Relevant nodes"
:menu-item-action #'(lambda nil (setf *flash-relevant-nodes* t)))
(make-instance 'menu-item
:menu-item-title " Support-link-bases"
:menu-item-action #'(lambda nil (setf *flash-support-link-bases* t)))
(make-instance 'menu-item
:menu-item-title " Support-links"
:menu-item-action #'(lambda nil (setf *flash-support-links* t)))
(make-instance 'menu-item
:menu-item-title " Terminal-deductive-ancestors"
:menu-item-action #'(lambda nil (setf *flash-terminal-deductive-ancestors* t)))
(make-instance 'menu-item
:menu-item-title "Graph Nodes:"
:style :underline
:menu-item-action #'(lambda nil))
(make-instance 'menu-item
:menu-item-title " Ancestors"
:menu-item-action
#'(lambda nil
(setf *message*
(make-top-message
"Click on nodes whose ancestors are to be graphed, then click elsewhere"))
(setf *graph-ancestors* t)))
(make-instance 'menu-item
:menu-item-title " Arguments for"
:menu-item-action
#'(lambda nil
(setf *message*
(make-top-message
"Click on node whose arguments are to be graphed"))
(setf *graph-node-arguments* t)))
(make-instance 'menu-item
:menu-item-title " Current-affected-nodes"
:menu-item-action
#'(lambda nil
(window-select (front-window :class 'og-window))
(graph-affected-nodes (front-window))))
(make-instance 'menu-item
:menu-item-title " Nodes relevant to ultimate-interests"
:menu-item-action
#'(lambda nil
(window-select (front-window :class 'og-window))
(graph-relevant-nodes (front-window))))
(make-instance 'menu-item
:menu-item-title " Relevant nodes"
:menu-item-action
#'(lambda nil
(setf
*message*
(make-top-message
"Click on nodes whose relevant-nodes are to be graphed, then click elsewhere"))
(setf *graph-relevant-nodes* t)))
(make-instance 'menu-item
:menu-item-title "Move All:"
:style :underline
:menu-item-action #'(lambda nil))
(make-instance 'menu-item
:menu-item-title " Nodes"
:menu-item-action #'move-all-nodes)
(make-instance 'menu-item
:menu-item-title " Interests"
:menu-item-action #'move-all-interests)
)))))))
(defmethod view-click-event-handler ((wind og-window) position)
(let ((selected-node (car (find-if #'(lambda (x) (ontop position (mem2 x))) (node-list wind)))))
(cond
(selected-node
(cond
(*flash-affected-nodes* (flash-affected-nodes selected-node wind))
(*flash-ancestors* (flash-ancestors selected-node wind))
(*flash-consequences* (flash-consequences selected-node wind))
(*flash-defeatees* (flash-defeaters selected-node wind))
(*flash-defeaters* (flash-defeatees selected-node wind))
(*flash-relevant-nodes* (flash-relevant-nodes selected-node wind))
(*flash-support-link-bases* (flash-support-link-bases selected-node wind))
(*flash-support-links* (flash-support-links selected-node wind))
(*flash-terminal-deductive-ancestors*
(flash-terminal-deductive-ancestors selected-node wind))
(*graph-ancestors* (select-nodes-to-graph-ancestors selected-node wind))
(*graph-node-arguments* (graph-node-arguments selected-node wind))
(*graph-relevant-nodes* (select-nodes-to-graph-relevant-nodes selected-node wind))
(*move-all-nodes* (set-guide-node selected-node))
((shift-key-p) (select-nodes-to-move selected-node wind))
((command-key-p) (inspect selected-node))
(t (display-node-sequent selected-node wind))))
(t
(cond
(*graph-relevant-nodes*
(graph-relevant-nodes wind *nodes-to-graph*) (setf *graph-relevant-nodes* nil)
(setf *nodes-to-graph* nil) (window-close *message*))
(*graph-ancestors*
(graph-ancestors *nodes-to-graph* wind) (setf *graph-ancestors* nil)
(setf *nodes-to-graph* nil) (window-close *message*))
(*nodes-to-be-moved* (move-nodes-in-window wind position))
(*move-all-nodes* (move-all-nodes-to position wind))
(t (let ((interest (car (rassoc position (interest-list wind) :test #'ontop))))
(cond
(interest
(cond
(*move-all-interests* (set-guide-interest interest))
((shift-key-p) (select-interests-to-move interest wind))
((command-key-p) (inspect interest))
(t (display-interest-sequent interest wind))))
(*move-all-interests* (move-all-interests-to position wind))
(*interests-to-be-moved* (move-interests-in-window wind position))
((shift-key-p) (select-nodes-in-region wind position))
(t
(setf *nodes-to-graph* nil) (when *message* (window-close *message*)))
))))))))
(defunction select-nodes-to-move (selected-node wind)
(if *message* (window-close *message*))
(cond
((member selected-node *nodes-to-be-moved*)
(redraw-node selected-node wind)
(pull selected-node *nodes-to-be-moved*)
(cond (*nodes-to-be-moved*
(setf *node-to-be-moved* (mem1 *nodes-to-be-moved*))
(setf *message*
(make-top-message
(cat-list
(list "Click on New Location for Node "
(princ-to-string (inference-number *node-to-be-moved*))
" or select more nodes to be moved"))))
(window-select wind))
(t (setf *node-to-be-moved* nil))))
(t
(frame-node selected-node *light-gray-color* wind)
(setf *message*
(make-top-message
(cat-list
(list "Click on New Location for Node "
(princ-to-string (inference-number selected-node))
" or select more nodes to be moved"))))
(setf *node-to-be-moved* selected-node)
(push selected-node *nodes-to-be-moved*)
(window-select wind))))
(defunction select-interests-to-move (interest wind)
(if *message* (window-close *message*))
(cond
((member interest *interests-to-be-moved*)
(redraw-interest interest wind)
(pull interest *interests-to-be-moved*)
(cond (*interests-to-be-moved*
(setf *interest-to-be-moved* (mem1 *interests-to-be-moved*))
(setf *message*
(make-top-message
(cat-list
(list "Click on New Location for Interest "
(princ-to-string (interest-number *interest-to-be-moved*))
" or select more interests to be moved"))))
(window-select wind))
(t (setf *interest-to-be-moved* nil))))
(t
(frame-interest interest *light-gray-color* wind)
(setf *message*
(make-top-message
(cat-list
(list "Click on New Location for Interest "
(princ-to-string (Interest-number interest))
" or select more interests to be moved"))))
(setf *interest-to-be-moved* interest)
(push interest *interests-to-be-moved*)
(window-select wind))))
(defunction make-top-message (string)
(let ((width (* 8 (length string))))
(make-instance 'windoid
:window-type :tool
:window-title string
:view-position
(make-point (+ (point-h *open-position*) (round (/ (- *screen-width* width) 2)))
(point-v *open-position*))
:view-size width
:close-box-p nil
:view-font '("Helvetica" 12 :srcor :plain))))
(defunction redraw-node (node view)
(draw-just-node (node-position node view) view node (node-color node view)))
(defunction redraw-interest (interest view)
(draw-just-interest (interest-position interest view) view interest))
(defunction select-nodes-to-graph-relevant-nodes (selected-node wind)
(cond
((member selected-node *nodes-to-graph*)
(redraw-node selected-node wind)
(pull selected-node *nodes-to-graph*)
(when (null *nodes-to-graph*)
(setf *graph-relevant-nodes* nil) (window-close *message*)))
(t
(push selected-node *nodes-to-graph*)
(frame-node selected-node *light-gray-color* wind)
(window-select wind))))
(defunction select-nodes-to-graph-ancestors (selected-node wind)
(cond
((member selected-node *nodes-to-graph*)
(redraw-node selected-node wind)
(pull selected-node *nodes-to-graph*)
(when (null *nodes-to-graph*)
(setf *graph-ancestors* nil) (window-close *message*)))
(t
(push selected-node *nodes-to-graph*)
(frame-node selected-node *light-gray-color* wind)
(window-select wind))))
(defunction flash-affected-nodes (selected-node wind)
(flash-nodes
(subset #'(lambda (n) (assoc n (node-list wind)))
(mem2 (compute-effects (car (support-links selected-node)))))
wind *yellow-color* 5
(cat-list
(list "Node " (write-to-string (inference-number selected-node)) " has no affected-nodes")))
(setf *flash-affected-nodes* nil))
(defunction flash-ancestors (selected-node wind)
(flash-nodes
(subset #'(lambda (n) (assoc n (node-list wind))) (node-ancestors selected-node))
wind *blue-color* 5
(cat-list
(list "Node " (write-to-string (inference-number selected-node)) " has no ancestors")))
(setf *flash-ancestors* nil))
(defunction flash-consequences (selected-node wind)
(flash-nodes
(subset #'(lambda (n) (assoc n (node-list wind)))
(mapcar #'support-link-target (consequent-links selected-node)))
wind *blue-color* 10
(cat-list
(list "Node " (write-to-string (inference-number selected-node)) " has no consequences")))
(setf *flash-consequences* nil))
(defunction flash-defeaters (selected-node wind)
(flash-nodes
(subset #'(lambda (n) (assoc n (node-list wind)))
(mapcar #'support-link-target (node-defeatees selected-node)))
wind *red-color* 10
(cat-list
(list "Node " (write-to-string (inference-number selected-node)) " has no defeatees")))
(setf *flash-defeatees* nil))
(defunction flash-defeatees (selected-node wind)
(flash-nodes
(subset #'(lambda (n) (assoc n (node-list wind)))
(flash-nodes (unionmapcar+ #'support-link-defeaters (support-links selected-node))
wind *red-color* 10
(cat-list
(list "Node " (write-to-string (inference-number selected-node)) " has no defeaters"))))
wind *red-color* 10)
(setf *flash-defeaters* nil))
(defunction flash-relevant-nodes (selected-node wind)
(let ((rn *relevant-nodes*))
(compute-relevant-nodes (list selected-node))
(flash-nodes
(subset #'(lambda (n) (assoc n (node-list wind))) *relevant-nodes*)
wind *red-color* 10
(cat-list
(list "Node " (write-to-string (inference-number selected-node)) " has no relevant-nodes")))
(setf *relevant-nodes* rn))
(setf *flash-relevant-nodes* nil))
(defunction flash-support-link-bases (selected-node wind)
(flash-nodes
(subset #'(lambda (n) (assoc n (node-list wind)))
(unionmapcar+ #'support-link-basis (support-links selected-node)))
wind *blue-color* 10
(cat-list
(list "Node " (write-to-string (inference-number selected-node)) " has no support-link-bases")))
(setf *flash-support-link-bases* nil))
(defunction flash-support-links (selected-node wind)
(let ((links (support-links selected-node)))
(cond
(links
(dolist (l links)
(let ((mes
(make-top-message
(cat "Support-link " (princ-to-string (support-link-number L))))))
(flash-nodes (subset #'(lambda (n) (assoc n (node-list wind)))
(support-link-basis l))
wind *blue-color* 5)
(window-close mes))))
(t
(let ((mes
(make-top-message
(cat-list
(list "Node " (write-to-string (inference-number selected-node)) " has no support-links")))))
(sleep 1)
(window-close mes)))))
(setf *flash-support-links* nil))
(defunction flash-terminal-deductive-ancestors (selected-node wind)
(flash-nodes
(subset #'(lambda (n) (assoc n (node-list wind)))
(compute-terminal-deductive-ancestors selected-node))
wind *blue-color* 5
(cat-list
(list "Node " (write-to-string (inference-number selected-node))
" has no terminal-deductive-ancestors")))
(when (not (shift-key-p))
(setf *flash-terminal-deductive-ancestors* nil)))
(defunction graph-node-arguments (selected-node wind)
(setf *graph-arguments* t)
(setf *graph-node-arguments* nil)
(window-close *message*)
(with-cursor *watch-cursor*
(show-arguments-for selected-node wind)))
(defunction move-nodes-in-window (wind new-position)
(let* ((assoc (assoc *node-to-be-moved* (node-list wind)))
(move-h (- (point-h new-position) (point-h (mem2 assoc))))
(move-v (- (point-v new-position) (point-v (mem2 assoc)))))
(dolist (n *nodes-to-be-moved*)
(let ((assoc (assoc n (node-list wind))))
(pull assoc (node-list wind))
(push (list n
(make-point
(+ (point-h (mem2 assoc)) move-h)
(+ (point-v (mem2 assoc)) move-v))
(mem3 assoc)) (node-list wind))))
(setf *node-to-be-moved* nil)
(setf *nodes-to-be-moved* nil)
(window-close *message*)
(invalidate-view wind t)))
(defunction move-interests-in-window (wind position)
(let* ((assoc (assoc *interest-to-be-moved* (interest-list wind)))
(move-h (- (point-h position) (point-h (cdr assoc))))
(move-v (- (point-v position) (point-v (cdr assoc)))))
(dolist (n *interests-to-be-moved*)
(let ((assoc (assoc n (interest-list wind))))
(pull assoc (interest-list wind))
(push (cons n
(make-point
(+ (point-h (cdr assoc)) move-h)
(+ (point-v (cdr assoc)) move-v)))
(interest-list wind))))
(setf *interest-to-be-moved* nil)
(setf *interests-to-be-moved* nil)
(window-close *message*)
(invalidate-view wind t)))
(defunction flash-queried-node ()
(setf *menu-dialog*
(make-instance 'dialog
:window-type :double-edge-box
:view-position #@(60 51)
:view-size #@(222 98)
:close-box-p nil
:view-font '("Chicago" 12 :srcor :plain)
:view-subviews
(list
(make-dialog-item
'static-text-dialog-item #@(22 15) #@(177 34)
"Enter node-number and type a carriage-return."
'nil
:text-justification :center)
(make-dialog-item
'editable-text-dialog-item #@(86 64) #@(48 16)
" ?"
#'(lambda (item)
(let ((text (dialog-item-text item)))
(when (and (> (length text) 0)
(equal (substring text (1- (length text))) "
"))
(let ((node (node (read-from-string text)))
(window (front-window :class 'og-window)))
(window-close *menu-dialog*)
(invalidate-view window t)
(when node
(window-select window)
(flash-nodes
(list node) window *yellow-color* 5))))))
:allow-returns t)))))
(defunction flash-queried-support-link ()
(setf *menu-dialog*
(make-instance 'dialog
:window-type :double-edge-box
:view-position #@(60 51)
:view-size #@(222 98)
:close-box-p nil
:view-font '("Chicago" 12 :srcor :plain)
:view-subviews
(list
(make-dialog-item
'static-text-dialog-item #@(9 12) #@(240 54)
"Enter support-link-number and type a carriage-return."
'nil
:text-justification :center)
(make-dialog-item
'editable-text-dialog-item #@(86 64) #@(48 16)
" ?"
#'(lambda (item)
(let ((text (dialog-item-text item)))
(when (and (> (length text) 0)
(equal (substring text (1- (length text))) "
"))
(let ((link (support-link (read-from-string text))))
(window-close *menu-dialog*)
(when link
(window-select (front-window :class 'og-window))
(flash-nodes
(cons (support-link-target link) (support-link-basis link))
(front-window) *yellow-color* 5))))))
:allow-returns t)))))
(defunction frame-node (node color view)
(let* ((position (node-position node view))
(x (point-h position))
(y (point-v position))
(left (- x *node-radius*))
(top (- y *node-radius*))
(right (+ x *node-radius*))
(bottom (+ y *node-radius*)))
(set-pen-size view #@(3 3)) (set-fore-color view color)
(frame-oval view left top right bottom)
(set-pen-size view #@(1 1)) (set-fore-color view *line-color*)))
(defunction temporarily-frame-node (node color view)
(let* ((position (node-position node view))
(x (point-h position))
(y (point-v position))
(left (- x *node-radius*))
(top (- y *node-radius*))
(right (+ x *node-radius*))
(bottom (+ y *node-radius*)))
(set-pen-size view #@(3 3)) (set-fore-color view color)
(frame-oval view left top right bottom)
(sleep 1)
(erase-oval view left top right bottom)
(set-fore-color view (node-color node view))
(paint-oval view left top right bottom)
(set-fore-color view *black-color*)
(cond
((answered-queries node)
(set-pen-size view #@(3 3)) (set-fore-color view *red-color*)
(frame-oval view left top right bottom)
(set-pen-size view #@(1 1)) (set-fore-color view *black-color*))
(t
(set-pen-size view #@(1 1)) (set-fore-color view *black-color*)
(frame-oval view left top right bottom)))
(move-to view (- x 6) (+ y 1))
(princ (inference-number node) *og*)
(move-to view (- x (- *node-radius* 3)) (+ y 3))
))
(defunction frame-interest (interest color view)
(let* ((position (interest-position interest view))
(x (point-h position))
(y (point-v position))
(left (- x *node-radius*))
(top (- y *node-radius*))
(right (+ x *node-radius*))
(bottom (+ y *node-radius*)))
(set-pen-size view #@(3 3)) (set-fore-color view color)
(frame-oval view left top right bottom)
(set-pen-size view #@(1 1)) (set-fore-color view *line-color*)))
(defunction pause-graphics ()
(let ((win (front-window)))
(window-select (find-window "Listener"))
(read-char)
(window-select win)))
(defunction show-arguments-for (n window)
(setf *arg-number* 0 *nodes-used* nil *arguments* nil *nodes-done* nil)
(when (null window) (setf window (front-window)))
(push n *nodes-done*)
(push n *nodes-used*)
(dolist (arg (node-arguments n))
(when
(not
(some
#'(lambda (a2)
(and
(eq n (argument-node a2))
(subsetp (argument-links a2) arg)))
*arguments*))
(dolist (a2 *arguments*)
(when
(and
(eq n (argument-node a2))
(subsetp arg (argument-links a2)))
(pull a2 *arguments*)))
(let ((argument
(make-argument
:argument-number (incf *arg-number*)
:argument-links arg
:argument-node n
:argument-strength
(if (every #'(lambda (L) (null (defeating-assignment-trees L))) arg)
(minimum0 (mapcar #'support-link-strength arg)) 0)
:ultimate-interest (mem1 (answered-queries n))
:inclusive-arg-nodes (list n))))
(push argument *arguments*)
(dolist (m (motivating-nodes n))
(pushnew m (inclusive-arg-nodes argument))
(pushnew m *nodes-used*))
(dolist (L (argument-links argument))
(dolist (b (support-link-basis L))
(pushnew b (inclusive-arg-nodes argument))
(pushnew b *nodes-used*)
(dolist (m (motivating-nodes b))
(pushnew m (inclusive-arg-nodes argument))
(pushnew m *nodes-used*)))))))
(dolist (argument (reverse *arguments*))
(display-argument argument)
(when *graph-arguments*
(graph-nodes (inclusive-arg-nodes argument)
window
(cat-list
(list "Graph of Argument " (write-to-string (argument-number argument))
" for node " (write-to-string (inference-number n))))
t))))
(defunction move-all-nodes ()
(setf *message* (make-top-message "Select guide-node"))
(setf *move-all-nodes* t))
(defunction move-all-interests ()
(setf *message* (make-top-message "Select guide-interest"))
(setf *move-all-interests* t))
(defunction set-guide-node (node)
(setf *guide-node* node)
(window-close *message*)
(setf *message* (make-top-message "Click on new position for guide node")))
(defunction set-guide-interest (interest)
(setf *guide-interest* interest)
(window-close *message*)
(setf *message* (make-top-message "Click on new position for guide interest")))
(defunction move-all-nodes-to (new-position wind)
(when *guide-node*
(let* ((assoc (assoc *guide-node* (node-list wind)))
(move-h (- (point-h new-position) (point-h (mem2 assoc))))
(move-v (- (point-v new-position) (point-v (mem2 assoc)))))
(dolist (x (node-list wind))
(pull x (node-list wind))
(push (list (mem1 x)
(make-point
(+ (point-h (mem2 x)) move-h)
(+ (point-v (mem2 x)) move-v))
(mem3 x)) (node-list wind))))
(setf *guide-node* nil)
(setf *move-all-nodes* nil)
(window-close *message*)
(invalidate-view wind t)))
(defunction move-all-interests-to (new-position wind)
(when *guide-interest*
(let* ((assoc (assoc *guide-interest* (interest-list wind)))
(move-h (- (point-h new-position) (point-h (cdr assoc))))
(move-v (- (point-v new-position) (point-v (cdr assoc)))))
(dolist (x (interest-list wind))
(pull x (interest-list wind))
(push (cons (mem1 x)
(make-point
(+ (point-h (cdr x)) move-h)
(+ (point-v (cdr x)) move-v)))
(interest-list wind))))
(setf *guide-interest* nil)
(setf *move-all-interests* nil)
(window-close *message*)
(invalidate-view wind t)))
(defunction display-node-sequent (node wind)
(let* ((sequent (node-sequent node))
(identifier (cat "Node " (write-to-string (inference-number node))))
(formula (pretty (sequent-formula sequent)))
(sup (mapcar #'pretty (sequent-supposition sequent)))
(width (* 5 (maximum
(append (list (+ 10 (length identifier)) (length formula)) (mapcar #'length sup)))))
(height (if sup (* 12 (+ 2 (length sup))) 12))
(position (node-position node wind))
(node-h (point-h position))
(node-v (point-v position)))
(make-instance 'windoid
:window-type :tool
:view-position
(let ((h (+ (* 2 *node-radius*) node-h))
(hw (point-h (view-size wind)))
(v (+ 48 (* 2 *node-radius*) node-v))
(vw (point-v (view-size wind))))
(make-point (if (>= h hw) (- hw 120) h) (if (>= v vw) vw v)))
:view-size (make-point (+ 2 width) (+ 4 height))
:window-title identifier
:view-font '("Helvetica" 10 :srcor :plain)
:view-subviews
(list (make-dialog-item
'static-text-dialog-item
#@(1 2)
(make-point width height)
(vertical-string (cons formula (if sup (cons "given" sup))))
'nil
:view-font '("Helvetica" 10 :srcor :plain))))))
(defunction display-interest-sequent (interest wind)
(let* ((sequent (interest-sequent interest))
(identifier (cat "Interest " (write-to-string (interest-number interest))))
(formula (pretty (sequent-formula sequent)))
(sup (mapcar #'pretty (sequent-supposition sequent)))
(width (* 5 (maximum
(append (list (+ 10 (length identifier)) (length formula)) (mapcar #'length sup)))))
(height (if sup (* 12 (+ 2 (length sup))) 12))
(position (interest-position interest wind))
(interest-h (point-h position))
(interest-v (point-v position)))
(make-instance 'windoid
:window-type :tool
:view-position
(let ((h (+ (* 2 *node-radius*) interest-h))
(hw (point-h (view-size wind)))
(v (+ 48 (* 2 *node-radius*) interest-v))
(vw (point-v (view-size wind))))
(make-point (if (>= h hw) (- hw 120) h) (if (>= v vw) vw v)))
:view-size (make-point (+ 2 width) (+ 4 height))
:window-title identifier
:view-font '("Helvetica" 10 :srcor :plain)
:view-subviews
(list (make-dialog-item
'static-text-dialog-item
#@(1 2)
(make-point width height)
(vertical-string (cons formula (if sup (cons "given" sup))))
'nil
:view-font '("Helvetica" 10 :srcor :plain))))))
(defunction vertical-string (strings)
(let ((new-strings (list (car strings))))
(loop
(setf strings (cdr strings))
(when (null strings) (return (cat-list (reverse new-strings))))
(push "
" new-strings)
(push (car strings) new-strings))))
(defclass abbreviated-og-window (og-window) (window))
(defmethod view-draw-contents ((wind abbreviated-og-window))
(dolist (pos (node-list wind))
(when (not (cancelled-node (car pos)))
(draw-abbreviated-node (cadr pos) wind (car pos))))
(dolist (i (interest-list wind))
(when (not (cancelled-interest (car i)))
(draw-interest (cdr i) wind (car i)))))
(defunction draw-abbreviated-node (position view node)
(draw-just-node position view node (node-color node view))
(draw-abbreviated-support-links position view node)
(attach-arrows-to-defeated-nodes position view node))
(defunction draw-abbreviated-support-links (position view node)
(dolist (L (support-links node))
(when (defeasible? L)
(set-fore-color view *gray-color*)
(dolist (b (support-link-basis L))
(let ((pos-b (node-position b view)))
(when pos-b
(draw-arrow pos-b position view))))
(set-fore-color view *line-color*))
(dolist (b (compute-terminal-deductive-ancestors node))
(let ((pos-b (node-position b view)))
(when pos-b
(draw-arrow pos-b position view))))))
(defunction compute-strongly-relevant-nodes (nodes)
(setf *strongly-relevant-nodes* nil)
(dolist (node nodes) (add-strongly-relevant-nodes node))
*strongly-relevant-nodes*)
(defunction add-strongly-relevant-nodes (node)
(when (not (member node *strongly-relevant-nodes*))
(push node *strongly-relevant-nodes*)
(dolist (m (motivating-nodes node))
(add-strongly-relevant-nodes m))
(dolist (L (support-links node))
(when (defeasible? L)
(dolist (b (support-link-basis L)) (add-strongly-relevant-nodes b))
(dolist (d (support-link-defeaters L)) (add-strongly-relevant-nodes d))))
(dolist (b (compute-terminal-deductive-ancestors node))
(add-strongly-relevant-nodes b))))
(defunction compute-terminal-deductive-ancestors (node)
(setf *terminal-deductive-ancestors* nil *nodes-done* nil)
(add-terminal-deductive-ancestors node)
*terminal-deductive-ancestors*)
(defunction add-terminal-deductive-ancestors (node)
(when (not (member node *nodes-done*))
(push node *nodes-done*)
(dolist (L (support-links node))
(when
(not (defeasible? L))
(dolist (b (support-link-basis L))
(when
(or (initial-node b) (some #'defeasible? (support-links b)))
(pushnew b *terminal-deductive-ancestors*))
(add-terminal-deductive-ancestors b))))))
(defunction initial-node (node)
(or (null (support-links node))
(some #'(lambda (L) (null (support-link-basis L))) (support-links node))))
(defunction draw-abbreviated-display (window &optional (title "Abbreviated Node Display"))
(let ((wind (find-window title)))
(when wind (window-close wind)))
(let ((view (make-instance 'abbreviated-og-window
:view-position *open-position*
:window-title title
:view-size (make-point *screen-width* *screen-height*)))
(nodes (compute-strongly-relevant-nodes
(unionmapcar+ #'query-answers *ultimate-epistemic-interests*))))
(setf (node-list view) (subset #'(lambda (x) (member (car x) nodes)) (node-list window)))
(invalidate-view view)))
(defunction flash-terminal-deductive-ancestors (selected-node wind)
(flash-nodes
(subset #'(lambda (n) (assoc n (node-list wind)))
(compute-terminal-deductive-ancestors selected-node))
wind *blue-color* 5
(cat-list
(list "Node " (write-to-string (inference-number selected-node))
" has no terminal-deductive-ancestors")))
(setf *flash-ancestors* nil))
(defunction select-nodes-in-region (wind position)
(cond
((double-click-p)
(line-to wind position)
(move-to wind position)
(line-to wind *region-start-position*)
(setf *selection-region* (close-region wind))
(dolist (x (node-list wind))
(when (point-in-region-p *selection-region* (mem2 x))
(frame-node (mem1 x) *light-gray-color* wind)
(setf *node-to-be-moved* (mem1 x))
(push (mem1 x) *nodes-to-be-moved*)))
; (paint-region wind *selection-region*)
(when *nodes-to-be-moved*
(when *message* (window-close *message*))
(setf *message*
(make-top-message
(cat-list
(list "Click on New Location for Node "
(princ-to-string (inference-number (mem1 *nodes-to-be-moved*)))
" or select more nodes to be moved")))))
(setf *selection-region* nil)
(setf *region-start-position* nil)
(set-pen-size wind #@ (1 1))
(set-fore-color wind *line-color*))
((null *region-start-position*)
(setf *region-start-position* position)
(move-to wind position)
(open-region wind)
(pen-show wind)
(set-pen-size wind #@ (4 4))
(set-fore-color wind *gray-color*)
; (when *message* (window-close *message*))
; (setf *message* (make-top-message "Enclose nodes to be moved"))
)
(t
(line-to wind position)
(move-to wind position)
)))
;(load (merge-pathnames oscar-pathname "Graph-nodes.lsp"))