home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e070 / 5.ddi / EXPLORER / VIEWER / FRAMES.P < prev    next >
Encoding:
Text File  |  1984-10-13  |  3.6 KB  |  102 lines
  1. ;;;; This file contains the frames procedures.
  2.  
  3. ;;; This section contains FPUT and its auxiliaries.
  4.  
  5. (DEFUN FPUT (FRAME SLOT FACET VALUE)
  6.   (LET ((VALUE-LIST (FOLLOW-PATH (LIST SLOT FACET)
  7.                                  (FGET-FRAME FRAME))))
  8.     (COND ((MEMBER VALUE VALUE-LIST) NIL)
  9.           (T (RPLACD (LAST VALUE-LIST) (LIST VALUE))
  10.              VALUE))))
  11.  
  12. (DEFUN FOLLOW-PATH (PATH A-LIST)
  13.   (COND ((NULL PATH) A-LIST)
  14.         (T (FOLLOW-PATH (REST PATH) (EXTEND (FIRST PATH) A-LIST)))))
  15.  
  16. (DEFUN EXTEND (KEY A-LIST)
  17.   (COND ((ASSOC KEY (REST A-LIST)))
  18.         (T (SECOND (RPLACD (LAST A-LIST) (LIST (LIST KEY)))))))
  19.  
  20. (DEFUN FGET-FRAME (FRAME)
  21.   (COND ((GET FRAME 'FRAME))                            ;Frame already made?
  22.         (T (SETF (GET FRAME 'FRAME) (LIST FRAME)))))    ;If not, make one.
  23.  
  24. ;;; This section contains FGET and FREMOVE.
  25.  
  26. (DEFUN FGET (FRAME SLOT FACET)
  27.   (REST (ASSOC FACET (REST (ASSOC SLOT (REST (GET FRAME 'FRAME)))))))
  28.  
  29. (DEFUN FREMOVE (FRAME SLOT FACET VALUE)
  30.   (LET ((VALUE-LIST (FOLLOW-PATH (LIST SLOT FACET)
  31.                                  (FGET-FRAME FRAME))))
  32.     (COND ((MEMBER VALUE VALUE-LIST)
  33.            (DELETE VALUE VALUE-LIST)
  34.            T)
  35.           (T NIL))))
  36.  
  37. ;;; This section contains procedures for using defaults and demons.
  38.  
  39. (DEFUN FPUT-P (FRAME SLOT FACET VALUE)
  40.   (COND ((FPUT FRAME SLOT FACET VALUE)
  41.          (MAPFIRST #'(LAMBDA (E)                           ;Use procedures.
  42.                      (MAPFIRST #'(LAMBDA (DEMON) (FUNCALL DEMON FRAME SLOT))
  43.                              (FGET E SLOT 'IF-ADDED)))
  44.                  (FGET-CLASSES FRAME))
  45.          VALUE)))
  46.  
  47. (DEFUN FGET-V-D (FRAME SLOT)
  48.   (COND ((FGET FRAME SLOT 'VALUE))
  49.         ((FGET FRAME SLOT 'DEFAULT))))
  50.  
  51. (DEFUN FGET-V-D-P (FRAME SLOT)
  52.   (COND ((FGET FRAME SLOT 'VALUE))              ;Try values first.
  53.         ((FGET FRAME SLOT 'DEFAULT))            ;Then try defaults.
  54.         (T (MAPCAN                              ;Combine results, if any.
  55.             #'(LAMBDA (DEMON) (FUNCALL DEMON FRAME SLOT))
  56.             (FGET FRAME SLOT 'IF-NEEDED)))))
  57.  
  58. ;;; This section contains procedures for using inherited values,
  59. ;;; defaults, and demons.
  60.  
  61. (DEFUN FGET-I (FRAME SLOT)
  62.   (FGET-I1 (FGET-CLASSES FRAME) SLOT))
  63.  
  64. (DEFUN FGET-I1 (FRAMES SLOT)
  65.   (COND ((NULL FRAMES) NIL)                     ;Give up?
  66.         ((FGET (FIRST FRAMES) SLOT 'VALUE))       ;Got something?
  67.         (T (FGET-I1 (REST FRAMES) SLOT))))       ;Climb tree.
  68.  
  69. (DEFUN FGET-Z (FRAME SLOT)
  70.   (FGET-Z1 SLOT (FGET-CLASSES FRAME)))
  71.  
  72. (DEFUN FGET-Z1 (S C)
  73.   (COND ((NULL C) NIL)
  74.         ((FGET-V-D-P (FIRST C) S))
  75.         (T (FGET-Z1 S (REST C)))))
  76.  
  77. (DEFUN FGET-CLASSES (START)
  78.   (REVERSE (FGET-CLASSES1 (LIST START) NIL)))
  79.  
  80. (DEFUN FGET-CLASSES1 (Q C)
  81.   (COND ((NULL Q) C)
  82.         (T (FGET-CLASSES1 (APPEND (FGET (FIRST Q) 'A-KIND-OF 'VALUE)
  83.                                   (REST Q))
  84.                           (ADJOIN (CAR Q) C)))))
  85.  
  86. ;;; This section contains representative demons.
  87.  
  88. (DEFUN ASK (FRAME SLOT)
  89.   (FORMAT T "Please supply a value for ~a's ~a" FRAME SLOT)
  90.   (TERPRI)                              ;Start new line.
  91.   (LET ((RESPONSE (READ)))              ;Get user's answer.
  92.     (COND (RESPONSE (LIST RESPONSE))    ;Return list with answer if
  93.           (T NIL))))                    ; RESPONSE is other than NIL.
  94.  
  95. (DEFUN CALCULATE-WEIGHT (FRAME SLOT)
  96.   (LET ((HEIGHT (FGET-V-D FRAME 'HEIGHT)))
  97.     (COND (HEIGHT (LIST (FPUT FRAME
  98.                               'WEIGHT
  99.                               'VALUE
  100.                               (* 33 (FIRST HEIGHT))))))))
  101.  
  102.