-
Notifications
You must be signed in to change notification settings - Fork 0
/
enumeration.lisp
executable file
·147 lines (131 loc) · 6.35 KB
/
enumeration.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
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
;#!/usr/local/bin/sbcl --script
;;;; Hey, Emacs, this is a -*- Mode: Lisp; Syntax: Common-Lisp -*- file!
;;;;
;;;; Lisp is a programmable programming language.
;;;; -- John Foderaro
;;;;
;;;; Name: enumeration.lisp
;;;;
;;;; Started: Thu Sep 12 15:11:20 2019
;;;; Modifications:
;;;;
;;;; Purpose:
;;;;
;;;;
;;;;
;;;; Calling Sequence:
;;;;
;;;;
;;;; Inputs:
;;;;
;;;; Outputs:
;;;;
;;;; Example:
;;;;
;;;; Notes:
;;;; http://defenum.sourceforge.net/introduction.html
;;;; https://rosettacode.org/wiki/Enumerations#Clojure
;;;; http://quickdocs.org/cl-enumeration/api
;;;; https://common-lisp.net/project/cl-enumeration/
;;;;
;;;;
;(load "/Users/dsletten/lisp/packages/test.lisp")
;(defpackage :enumeration (:use :common-lisp :test) (:export :defenum))
(defpackage :enumeration (:use :common-lisp) (:export :defenum))
(in-package :enumeration)
(defclass enumeration ()
()
(:documentation "A fixed set of pre-defined values."))
(defmethod make-instance :around ((class (eql (find-class 'enumeration))) &rest initargs)
(find-token class initargs)
(apply #'call-next-method class initargs))
;;;
;;; This is not working???
;;;
(defgeneric find-token (class args)
(:documentation "Control access to instance creation."))
;(defmacro defenum (name slots print-method &rest instances)
(defmacro defenum (name (&rest instances))
(let* ((init-instances (gensym))
(values-instance (gensym))
(slots (mapcar #'(lambda (symbol) (intern (symbol-name symbol))) '(name description)))
(instances-slot (intern "INSTANCES"))
(print-method (intern "DESCRIPTION"))
(values-class (read-from-string (format nil "~S-values" name)))
(find-method (intern (format nil "FIND-~S" name)))
(token (gensym))
(symbol-macros (mapcar #'(lambda (initargs)
(let ((instance-name (first initargs)))
; (let ((instance-name (getf initargs :name)))
`(define-symbol-macro ,instance-name (,find-method ',instance-name))))
instances)))
`(progn
(defclass ,name (enumeration)
,(mapcar #'(lambda (slot-name)
`(,slot-name :initarg ,(intern (symbol-name slot-name) 'keyword) :reader ,slot-name))
slots))
(defclass ,values-class ()
((,instances-slot :initarg :instances :reader ,instances-slot :type (list ,name))))
(defgeneric ,find-method (,(first slots)))
(defmethod print-object ((,name ,name) stream)
(write-string (,print-method ,name) stream))
(let ((token ',token))
(defmethod find-token ((class (eql (find-class ',name))) args)
(if (eq token (getf args :token))
t
(error "Can't create any more ~A!" ',name)))
; (let* ((,init-instances (mapcar #'(lambda (initargs) (apply #'make-instance ',name initargs)) ',instances))
(let* ((,init-instances (mapcar #'(lambda (initargs) (make-instance ',name :name (first initargs) :description (second initargs) :token token :allow-other-keys t)) ',instances))
(,values-instance (make-instance ',values-class :instances ,init-instances)))
(defmethod ,find-method (,(first slots))
(find-if #'(lambda (,name) (eql (,(first slots) ,name) ,(first slots))) (,instances-slot ,values-instance)))))
,@symbol-macros)))
;;;
;;; Correct expansion but problems with symbols interned in enumeration package...
;;; Uh...hard-wired WOOD!!
;;;
;; (defmacro defenum (name (&rest instances))
;; (let ((init-instances (gensym))
;; (values-instance (gensym))
;; (slots '(name descripton))
;; (print-method 'description)
;; (values-class (read-from-string (format nil "~S-values" name)))
;; (find-method (read-from-string (format nil "find-~S" name)))
;; (symbol-macros (mapcar #'(lambda (initargs)
;; (let ((instance-name (getf initargs :name)))
;; `(define-symbol-macro ,instance-name (find-wood ',instance-name))))
;; instances)))
;; `(progn
;; (defclass ,name ()
;; ,(mapcar #'(lambda (slot-name)
;; `(,slot-name :initarg ,(intern (symbol-name slot-name) 'keyword) :reader ,slot-name))
;; slots))
;; (defclass ,values-class ()
;; ((instances :initarg :instances :reader instances :type (list ,name))))
;; (defgeneric ,find-method (name))
;; (defmethod print-object ((,name ,name) stream)
;; (write-string (,print-method wood) stream))
;; (let* ((,init-instances (mapcar #'(lambda (initargs) (apply #'make-instance ',name initargs)) ',@instances))
;; (,values-instance (make-instance ',values-class :instances ,init-instances)))
;; (defmethod ,find-method (name)
;; (find-if #'(lambda (,name) (eql (name ,name) name)) (instances ,values-instance))))
;; ,@symbol-macros)))
;; ,@(mapcar #'(lambda (initargs)
;; (let ((instance-name (getf initargs :name)))
;; `(define-symbol-macro ,instance-name (find-wood ',instance-name))))
;; instances))))
;; ,@(mapcar #'(lambda (initargs)
;; (let ((instance-name (getf initargs ':name)))
;; `(define-symbol-macro ,instande-name (find-wood ',instance-name))))
;; ',@instances))))
;; (define-symbol-macro alder (find-wood 'alder))
;; (define-symbol-macro indian-rosewood (find-wood 'indian-rosewood))
;; (define-symbol-macro brazilian-rosewood (find-wood 'brazilian-rosewood))
;; (define-symbol-macro mahogany (find-wood 'mahogany))
;; (define-symbol-macro sitka (find-wood 'sitka))
;; '((:name maple :description "Maple")
;; (:name alder :description "Alder")
;; (:name indian-rosewood :description "Indian Rosewood")
;; (:name brazilian-rosewood :description "Brazilian Rosewood")
;; (:name mahogany :description "Mahogany")
;; (:name sitka :description "Sitka Spruce"))))