 (lambda (symbol)
   (if (funcall 'ccl::package-%local-nicknames *package*)
       (ccl::%decls-body (funcall 'intern (funcall 'symbol-name symbol) ':keyword))
       (funcall 'ccl::%pkg-ref-intern
                (funcall 'symbol-name symbol)
                '(#:load-time-eval (funcall #<Anonymous Function #x3020034D62DF>)))))

5 
6 (defun hash-compare (x y)
7   "hash compare compare twos symbols"
8   (let ((hash-x (sxhash x))
9         (hash-y (sxhash y)))
10     (cond  ((< hash-x hash-y) -1)
11            ((> hash-x hash-y)  1)
12            (t                  0))))

 (lambda (x y)
   (let ((hash-x (funcall 'sxhash x)) (hash-y (funcall 'sxhash y)))
     (if (ccl::numcmp ':lt hash-x hash-y) -1 (if (ccl::numcmp ':gt hash-x hash-y) 1 0))))

13 
14 (defun sycamore-plist-symbol-map (plist)
15   (sycamore:alist-tree-map (alexandria:plist-alist plist) #'hash-compare))

16 
17 (defun sycamore-symbol-map-plist (tree-map)
18   (alexandria:alist-plist (sycamore:tree-map-alist tree-map)))

19 
20 ;; from
21 ;; https://stackoverflow.com/questions/11067899/is-there-a-generic-method-for-cloning-clos-objects
22 
23 ;; Don't need it to be an object on non standard-classes for this
24 ;; project, if so, we can promote it to the old form of being a
25 ;; defgeneric.
26 
27 (-> copy-instance (standard-object &rest t &key &allow-other-keys) standard-object)
28 (defun copy-instance (object &rest initargs &key &allow-other-keys)
29   "Makes and returns a shallow copy of OBJECT.
30 
31   An uninitialized object of the same class as OBJECT is allocated by
32   calling ALLOCATE-INSTANCE.  For all slots returned by
33   CLASS-SLOTS, the returned object has the
34   same slot values and slot-unbound status as OBJECT.
35 
36   REINITIALIZE-INSTANCE is called to update the copy with INITARGS."
37   (let* ((class (class-of object))
38          (copy (allocate-instance class)))
39     (dolist (slot (c2mop:class-slots class))
40       ;; moved the mapcar into a let, as allocation wise, CCL
41       ;; preformed better this way.
42       (let ((slot-name (c2mop:slot-definition-name slot)))
43         (when (slot-boundp object slot-name)
44           (setf (slot-value copy slot-name)
45                 (slot-value object slot-name)))))
46     (values
47      (apply #'reinitialize-instance copy initargs))))

 (lambda (object &rest initargs &allow-other-keys)
   (let* ((class (funcall 'class-of object)) (copy (funcall 'allocate-instance class)))
     (progn (let* ((#:g50516 (funcall 'ccl:class-slots class)))
              (tagbody (go #:g50518)
                       (#:g50517 nil (0) #<var #:|tagbody-catch-tag| #x3020034F86DD> t t)
                       (tagbody (let* ((slot (car #:g50516)))
                                  (tagbody (let* ((slot-name (funcall 'ccl:slot-definition-name slot)))
                                             (if (funcall 'slot-boundp object slot-name)
                                                 (funcall 'ccl::set-slot-value
                                                          copy
                                                          slot-name
                                                          (funcall 'slot-value object slot-name))
                                                 nil)))))
                       (setq #:g50516 (ccl::%cdr (ccl::typed-form 'list #:g50516)))
                       (#:g50518 nil (0) #<var #:|tagbody-catch-tag| #x3020034F86DD> t nil)
                       (if (not ':ne #:g50516) (go #:g50517) nil)))
            (values (apply 'reinitialize-instance copy initargs)))))

48 
49 ;; I should use this for object equality, namely the slot values trick
50 
51 ;; Please abstract out this logic. Too much of the same pattern!!!
52 
53 (defun alist-values (alist)
54   "Takes a potentially nested alist and returns the values
55 
56 (alist-values '((:plane . :fi-plane) (:point . ((:x . fi-point-x) (:y . fi-point-y)))))
57 
58 ==>
59 
60 (:FI-PLANE FI-POINT-X FI-POINT-Y)"
61   (mapcan (lambda (apair)
62             (if (not (listp (cdr apair)))
63                 (list (cdr apair))
64                 (alist-values (cdr apair))))
65           alist))

 (lambda (alist)
   (funcall 'mapcan
            (function (lambda (apair)
                        (if (eq ':ne (ccl::lisptag (cdr apair)) 3)
                            (cons (cdr apair) nil)
                            (funcall 'alist-values (cdr apair)))))
            alist))

66 
67 (defun nested-alist-keys (alist)
68   "Takes a potentially nested alist and returns all the keys
69 
70 (nested-alist-keys '((:plane . :fi-plane) (:point . ((:x . fi-point-x) (:y . fi-point-y)))))
71 
72 ==>
73 
74 (:PLANE :POINT :X :Y)"
75   (mapcan (lambda (apair)
76             (if (not (listp (cdr apair)))
77                 (list (car apair))
78                 (cons (car apair) (nested-alist-keys (cdr apair)))))
79           alist))

 (lambda (alist)
   (funcall 'mapcan
            (function (lambda (apair)
                        (if (eq ':ne (ccl::lisptag (cdr apair)) 3)
                            (cons (car apair) nil)
                            (cons (car apair) (funcall 'nested-alist-keys (cdr apair))))))
            alist))

80 
81 (defun leaf-alist-keys (alist)
82   "Takes a nested alist and gives back all the keys on the leaves
83 
84 (leaf-alist-keys '((:plane . :fi-plane) (:point . ((:x . fi-point-x) (:y . fi-point-y)))))
85 
86 ==>
87 
88 (:PLANE :X :Y)"
89   (mapcan (lambda (apair)
90             (if (not (listp (cdr apair)))
91                 (list (car apair))
92                 (leaf-alist-keys (cdr apair))))
93           alist))

 (lambda (alist)
   (funcall 'mapcan
            (function (lambda (apair)
                        (if (eq ':ne (ccl::lisptag (cdr apair)) 3)
                            (cons (car apair) nil)
                            (funcall 'leaf-alist-keys (cdr apair)))))
            alist))

Coverage report: home:Documents;Work;Repo;alu;src;util;utils.lisp.newest