-
Notifications
You must be signed in to change notification settings - Fork 0
/
maps.lisp
135 lines (114 loc) · 4.78 KB
/
maps.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
;;;; org.unaen.cl.maps/maps.lisp
(uiop:define-package #:org.unaen.cl.maps
(:documentation "Simple Set source for maps.")
(:shadow #:map)
(:use #:common-lisp)
(:export #:*map-test*
#:map
#:dimension
#:mapp
#:map-add
#:map-get
#:map-find-element))
(in-package #:org.unaen.cl.maps)
#| ---------- map ---------------------------------------------------------- |#
(defparameter *map-test* 'equal)
(defclass map ()
((stor :initform (make-hash-table :test *map-test*) ;Initialize first (or default dimension).
:accessor stor
:documentation "Internal storage for the map.")
(dimension :initarg :dimension
:initform 1
:reader dimension
:documentation "The number of input objects that are going to be mapped to the single output object."))
(:documentation "My own dumb multi-dimensional map implementation."))
(defgeneric mapp (object)
(:method ((map map))
t)
(:method (object)
nil))
(defun map (&key (dimension 1))
(declare (type (integer 1 *) dimension))
(make-instance 'map
:dimension dimension))
(defgeneric map-add (to-object from-object/objects-list map-instance)
(:documentation "Add a mapping from a tuple of elements to a single element in the form of a lisp list of objects to a single lisp object."))
(defmethod map-add :before (to-object from-object/s (map-inst map))
(when (/= (typecase from-object/s
(cons (list-length from-object/s))
(atom 1))
(dimension map-inst))
(error "Incorrect number of from-objects.")))
(labels ((map-add-rec (to-object from-objects-remaining nth-dimension)
"Recurse from-objects as hash table keys, setting or creating hash-tables for each dimension along the way."
(let ((nth-elt (first from-objects-remaining))
(nth+1-elt (second from-objects-remaining)))
(if nth+1-elt
(let ((nth+1-dimension (gethash nth-elt
nth-dimension)))
(etypecase nth+1-dimension
(hash-table (map-add-rec to-object
(rest from-objects-remaining)
nth+1-dimension))
(null (map-add-rec to-object
(rest from-objects-remaining)
(setf (gethash nth-elt
nth-dimension)
(make-hash-table :test *map-test*))))))
(setf (gethash nth-elt
nth-dimension)
to-object)))))
(defmethod map-add (to-object from-object (map-inst map))
(map-add-rec to-object
`(,from-object)
(stor map-inst)))
(defmethod map-add (to-object (from-objects cons) (map-inst map))
(map-add-rec to-object
from-objects
(stor map-inst))))
(defgeneric map-get (from-object/objects-list map-instance)
(:documentation "Get the output object mapping for a respective object or objects list."))
(defmethod map-get :before (from-obj/s (map-inst map))
(when (/= (typecase from-obj/s
(cons (list-length from-obj/s))
(atom 1))
(dimension map-inst))
(error "Incorrect number of from-objects.")))
(labels ((map-get-rec (from-objects-remaining nth-dimension)
"Recurse from-objects as hash table keys until reaching a non-nil to-object."
(let* ((nth-elt (first from-objects-remaining))
(nth+1-elt (second from-objects-remaining))
(nth+1-dimension (gethash nth-elt
nth-dimension)))
(if nth+1-elt
(etypecase nth+1-dimension
(hash-table (map-get-rec (rest from-objects-remaining)
nth+1-dimension))
(null 'nil))
nth+1-dimension))))
(defmethod map-get (from-object (map-inst map))
(map-get-rec (list from-object)
(stor map-inst)))
(defmethod map-get ((from-objects cons) (map-inst map))
(map-get-rec from-objects
(stor map-inst))))
(defmethod map-find-element (element (map map) &key test)
"Given an object and map stor and dimension with keyword test function, find and return first object for which (test element object) is true as well as the list of input dimension objects that map to the object."
(unless test
(setf test #'equal))
(with-slots ((stor stor) (dimension dimension)) map
(%map-find-element element stor dimension test)))
(defun %map-find-element (element stor dimension test)
(declare (type hash-table stor) (type (integer 0 *) dimension) (type function test))
(cond ((>= dimension 2) (loop :for object :being :the :hash-values :of stor :using (:hash-key object-in)
:do (multiple-value-bind (object-found object-in-list)
(%map-find-element element object (1- dimension) test)
(when object-found
(return-from %map-find-element
(values object-found
(cons object-in object-in-list)))))))
((= dimension 1) (loop :for object :being :the :hash-values :of stor :using (:hash-key object-in)
:do (when (funcall test element object)
(return-from %map-find-element
(values object
(list object-in))))))))