-
Notifications
You must be signed in to change notification settings - Fork 0
/
show-frame.lisp
116 lines (100 loc) · 4.22 KB
/
show-frame.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
;;; A simple frame system
;;; ------------------------------------------------------------
;;; - File: frames.lisp
;;; - Authors: Chris Riesbeck, Will Fitzgerald
;;; Inspired by code by Matt Togliatti, C25, Fall 90.
;;; - Most recent update: 11/15/94
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (SHOW-MEMORY concept [stream slots-p])
;;; Prints the tree of concepts under concept. Stream defaults
;;; to standard output. If slots-p is true, slots for each
;;; concept are printed. A concept's subtree and slots are
;;; printed once, even if the concept has multiple parents.
;;; (SHOW-FRAME concept)
;;; Pretty-prints the slots of a concept, the slots of the fillers
;;; and so on.
;;;
;;; Exs.
;;; > (require "show-frame")
;;; > (use-package :frames)
;;; > (show-memory 'm-index)
;;; ... prints the tree under M-INDEX
;;; > (show-memory 'm-index t t)
;;; ... prints the tree under M-INDEX, and the slots of each concept
;;; > (show-frame 'i-cheetah-chase-antelope)
;;; ... prints the slots of I-CHEETAH-CHASE-ANTELOPE and of its fillers
(require "frames")
(in-package :frames)
(export '(show-memory show-frame))
(defun show-memory (name
&optional (stream *standard-output*) slots-p
&aux shown)
(labels ((show (name prefix)
(let ((specs (specs-of name))
(slots (and slots-p (slots-of name))))
(cond ((member name shown)
(format stream
(if (or specs slots) "~S...~%" "~S~%") name))
(t
(format stream "~S~%" name)
(push name shown)
(when slots
(let ((bar (if specs "|" " ")))
(dolist (slot slots)
(if (slot-p slot)
(format stream "~A ~A ~S ~S~%" prefix bar
(slot-role slot)
(slot-filler slot))
;; :CONSTRAINTS or :METHODS
(format stream "~A ~A ~S are:~%"
prefix bar slot)))))
(when specs
(do ((next-prefix (format nil "~A | " prefix))
(last-prefix (format nil "~A " prefix))
(l specs (cdr l)))
((null (cdr l))
(format stream "~A +-- " prefix)
(show (car l) last-prefix))
(format stream "~A |-- " prefix)
(show (car l) next-prefix))))))))
(show name "")
name))
;;; Printing internal frame structures
;;; ----------------------------------------------------------------------
;;; (SHOW-FRAME name) => no values
;;; Prints the internals of the frame named in a readable fashion.
;;;
;;; SHOW-FRAME recursively prints the internal structure of all parts
;;; of the frame, if they haven't already been printed.
(defvar *frames-shown* nil)
(defun show-frame (name)
(let ((*frames-shown* '()))
(pprint-frame-info name 4)
(values)))
;;; (PPRINT-FRAME-INFO name left-margin) => undefined
;;; PPRINT-FRAME-INFO prints internal frame structures in a readable
;;; fashion, indented left-margin number of spaces.
(defun pprint-frame-info (name left-margin)
(unless (member name *frames-shown*)
(push name *frames-shown*)
(let ((frame (frame-of name)))
(unless (null frame)
(pprint-frame-type frame left-margin)
(pprint-frame-absts frame left-margin)
(pprint-frame-slots frame left-margin)))))
(defun pprint-frame-type (frame left-margin)
(let ((type (frame-type frame)))
(when type
(format t "~&~VTTYPE ~S~%" left-margin type))))
(defun pprint-frame-absts (frame left-margin)
(loop for abst in (frame-absts frame)
do (format t "~&~VTISA ~S~%" left-margin abst)))
(defun pprint-frame-slots (frame left-margin)
(loop for slot in (frame-slots frame)
do (format t "~&~VT~S ~S~%"
left-margin
(slot-role slot)
(slot-filler slot))
(pprint-frame-info (slot-filler slot)
(+ left-margin 2))))
(provide "show-frame")