-
-
Notifications
You must be signed in to change notification settings - Fork 0
/
generalized-lattice.lisp
105 lines (80 loc) · 4.03 KB
/
generalized-lattice.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
(in-package :cl-user)
(defpackage hyperlattices/generalized-lattice
(:nicknames generalized-lattice)
(:use c2cl hyperlattices/generic-interface hyperlattices/poset)
(:export #:generalized-lattice)
(:documentation "Implementation of the GENERALIZED-LATTICE superclass and dispatching methods. Not really intended for direct use, but exists for when the initial subtype is unknown and model-dependent."))
(in-package :hyperlattices/generalized-lattice)
(defclass generalized-lattice (poset)
((elements :accessor elements :initarg :elements :initform nil)
(sublattices :accessor sublattices :initarg :sublattices :initform nil))
(:metaclass funcallable-standard-class)
(:documentation "Implementation of the GENERALIZED-LATTICE algebraic datatype."))
(defun generalized-lattice (&key elements sublattices)
"Constructor function for the GENERALIZED-LATTICE algebraic datatype."
(make-instance 'generalized-lattice :elements elements :sublattices sublattices))
(defmethod supremum ((gl-alpha generalized-lattice))
(supremum-of gl-alpha))
(defmethod infimum ((gl-alpha generalized-lattice))
(infimum-of gl-alpha))
(defmethod join ((gl generalized-lattice) &rest gls)
(let ((sublattices (mapcar #'sublattices (cons gl gls)))
(elements (mapcar #'elements (cons gl gls))))
(if (every #'null sublattices)
(make-instance (class-of gl) :elements (reduce #'union elements))
(let ((sublattice (apply #'join sublattices)))
(make-instance (class-of gl) :elements (elements sublattice) :sublattices (list sublattice))))))
(defmethod meet ((gl generalized-lattice) &rest gls)
(let ((sublattices (mapcar #'sublattices (cons gl gls)))
(elements (mapcar #'elements (cons gl gls))))
(if (every #'null sublattices)
(make-instance (class-of gl) :elements (reduce #'intersection elements))
(let ((sublattice (apply #'meet sublattices)))
(make-instance (class-of gl) :elements (elements sublattice) :sublattices (list sublattice))))))
(defmethod element-of ((gl-alpha generalized-lattice) element)
gl-alpha)
(defmethod relation-of ((gl-alpha generalized-lattice) relation)
gl-alpha)
(defmethod supremum-of ((gl-alpha generalized-lattice))
gl-alpha)
(defmethod infimum-of ((gl-alpha generalized-lattice))
gl-alpha)
(defmethod member-p ((gl-alpha generalized-lattice))
gl-alpha)
(defmethod closure ((gl-alpha generalized-lattice))
gl-alpha)
(defmethod cover ((gl-alpha generalized-lattice))
gl-alpha)
(defmethod dimension ((gl-alpha generalized-lattice))
gl-alpha)
(defmethod chain ((gl-alpha generalized-lattice))
gl-alpha)
(defmethod antichain ((gl-alpha generalized-lattice))
gl-alpha)
(defmethod slice ((gl-alpha generalized-lattice) sublattice-index)
(let ((sublattice (nth sublattice-index (sublattices gl-alpha))))
(if sublattice
(let ((slice (make-instance (class-of gl-alpha))))
(setf (sublattices slice) (list sublattice))
(setf (elements slice) (elements sublattice))
(setf (sublattices gl-alpha) (list sublattice))
slice)
(error "Sublattice not found."))))
(defmethod combine ((gl generalized-lattice) &rest gls)
(reduce #'combine gls :from-end t :initial-value gl))
(defmethod longest-chain-p ((gl generalized-lattice) chain)
(= (length (chain gl)) (length chain)))
(defmethod largest-antichain-p ((gl generalized-lattice) antichain)
(let ((largest-antichain (antichain gl)))
(and (equal largest-antichain antichain)
(>= (length largest-antichain) (length (antichain (closure gl)))))))
(defmethod homomorphic-p ((lhs generalized-lattice) (rhs generalized-lattice))
(equal (supremum lhs) (supremum rhs)))
(defmethod isomorphic-p ((lhs generalized-lattice) (rhs generalized-lattice))
(and (homomorphic-p lhs rhs)
(homomorphic-p rhs lhs)))
(defmethod congruent-p ((lhs generalized-lattice) (rhs generalized-lattice))
(and (equal (supremum lhs) (supremum rhs))
(equal (infimum lhs) (infimum rhs))
(equal (elements lhs) (elements rhs))
(equal (sublattices lhs) (sublattices rhs))))