src/description.lisp

   1 (in-package :lisp-on-lines)
   2
   3 (define-layered-function description-of (thing)
   4   (:method (thing)
   5     (find-description 't)))
   6
   7 (defun description-print-name (description)
   8   (description-class-name (class-of description)))
   9
  10 (defun find-attribute (description attribute-name)
  11   (slot-value description attribute-name))
  12
  13
  14 (defun description-attributes (description)
  15   (mapcar (curry
  16            #'slot-value-using-class
  17            (class-of 'description)
  18            description)
  19           (class-slots (class-of description))))
  20
  21 (defvar *display-attributes* nil)
  22 (defun attribute-active-p (attribute)
  23   (or (null *display-attributes*)
  24       (find (attribute-name attribute) *display-attributes*)))
  25
  26 (define-layered-function attributes (description)
  27   (:method (description)
  28     (remove-if-not
  29      (lambda (attribute)
  30        (and (attribute-active-p attribute)
  31             (some #'layer-active-p
  32              (mapcar #'find-layer
  33                      (slot-definition-layers
  34                       (attribute-effective-attribute-definition attribute))))))
  35      (description-attributes description))))
  36
  37
  38 ;;; A handy macro.
  39 (defmacro define-description (name &optional superdescriptions &body options)
  40   (let ((description-name (defining-description name)))
  41     (destructuring-bind (&optional slots &rest options) options
  42       (let ((description-layers (cdr (assoc :in-description options))))
  43         (if description-layers
  44             `(progn ;eval-when (:compile-toplevel :load-toplevel :execute)
  45                ,@(loop
  46                     :for layer
  47                     :in description-layers
  48                     :collect `(define-description
  49                                   ,name ,superdescriptions ,slots
  50                                   ,@(acons
  51                                     :in-layer (defining-description layer)
  52                                     (remove :in-description options :key #'car)))))
  53             `(progn ;eval-when (:compile-toplevel :load-toplevel :execute)
  54                                         ;  `(progn
  55                (defclass ,description-name
  56                    ,(append (mapcar #'defining-description
  57                                     superdescriptions)
  58                             (unless (or (eq t name)
  59                                         (assoc :mixinp options))
  60                               (list (defining-description t))))
  61                  ,(if slots slots '())
  62                  ,@options
  63                  ,@(unless (assoc :metaclass options)
  64                            '((:metaclass standard-description-class))))
  65                (initialize-descriptions)
  66                (find-description ',name)))))))
  67
  68
  69
  70
  71
  72
  73
  74
  75
  76
  77
  78
  79
  80
  81
  82
  83
  84
  85
  86