1. ; Expression evals - Is your expression partial order?
2. ; ------------------------------
3. ; The Little Lisper 3rd Edition
4. ; Chapter 8
5. ; Exercise 10
6. ; Common Lisp
7. ; http://t...content-available-to-author-only...r.com/thelittlelisper
8. ; http://t...content-available-to-author-only...t.com/2010/06/little-lisper-chapter-8-friends-and.html
9. ; http://t...content-available-to-author-only...t.com/2010/06/little-lisper.html
10. ; ------------------------------
11. (setf r1 '((a b)(a a)(b b)))
12. (setf r2 '((c c)))
13. (setf r3 '((a c)(b c)))
14. (setf r4 '((a b)(b a)))
15. (setf f1 '((a 1)(b 2)(c 2)(d 1)))
16. (setf f2 '())
17. (setf f3 '((a 2)(b 1)))
18. (setf f4 '((1 \$)(3 *)))
19. (setf d1 '(a b))
20. (setf d2 '(c d))
21. (setf x 'a)
22. ; ------------------------------
23.
24. (defun first_ (l)
25. (cond
26. ((null l) '())
27. (t (car l))))
28.
29. (defun second_ (l)
30. (cond
31. ((null l) '())
32. (t (car (cdr l)))))
33.
34. (defun third_ (l)
35. (cond
36. ((null l) '())
37. (t (car (cdr (cdr l))))))
38.
39. (defun pair? (lat)
40. (cond
41. ((null lat) NIL)
42. ((atom lat) NIL)
43. ((and (and (not (eq (first_ lat) NIL))
44. (not (eq (second_ lat) NIL))))
45. (eq (third_ lat) NIL))
46. (t NIL)))
47.
48. (defun rel? (rel)
49. (cond
50. ((null rel) t)
51. ((atom rel) NIL)
52. ((pair? (car rel))
53. (rel? (cdr rel)))
54. (t NIL)))
55.
56. (defun eq-pair (pair-a pair-b)
57. (cond
58. ((null pair-a) NIL)
59. ((null pair-b) NIL)
60. ((atom pair-a) NIL)
61. ((atom pair-b) NIL)
62. ((not (pair? pair-a)) NIL)
63. ((not (pair? pair-b)) NIL)
64. ((and (eq (first_ pair-a)
65. (first_ pair-b))
66. (eq (second_ pair-a)
67. (second_ pair-b))))
68. (t NIL)))
69.
70. (defun member-pair? (pair rel)
71. (cond
72. ((null pair) t)
73. ((null rel) NIL)
74. ((not(pair? pair)) NIL)
75. ((not(rel? rel)) NIL)
76. ((eq-pair (car rel) pair) t)
77. (t (member-pair? pair (cdr rel)))))
78.
79. (defun member-rel? (rel1 rel2)
80. (cond
81. ((null rel1) t)
82. ((null rel2) NIL)
83. ((not (rel? rel1)) NIL)
84. ((not (rel? rel2)) NIL)
85. ((member-pair? (car rel1) rel2)
86. (member-rel? (cdr rel1) rel2))
87. (t NIL)))
88.
89. (defun build (a b)
90. (cons a (cons b '())))
91.
92. (defun idrel (s)
93. (cond
94. ((null s) '())
95. (t (cons (build (car s) (car s))
96. (idrel (cdr s))))))
97.
98. (defun makeset (lat)
99. (cond
100. ((null lat) '())
101. ;((member? (car lat) (cdr lat))
102. ((member_ (car lat) (cdr lat))
103. (makeset (cdr lat)))
104. (t (cons (car lat)
105. (makeset (cdr lat))))))
106.
107. (defun notatom (lat)
108. (not (atom lat)))
109.
110. (defun flatten (lat acc)
111. (cond
112. ((null lat) acc)
113. ((notatom (car lat))
114. (flatten (car lat) (flatten (cdr lat) acc)))
115. (t (flatten (cdr lat) (cons (car lat) acc)))))
116.
117. (defun domset (rel)
118. (cond
119. ((null rel) '())
120. (t (makeset (flatten rel '())))))
121.
122. (defun reflexive? (lat)
123. (cond
124. ((null lat) NIL)
125. (t (member-rel? (idrel (domset lat)) lat))))
126.
127. (defun reflexive? (lat)
128. (cond
129. ((null lat) NIL)
130. (t (member-rel? (idrel (domset lat)) lat))))
131.
132.
133. (defun member* (a l)
134. (cond
135. ((null l) NIL)
136. ((atom (car l))
137. (or
138. (eq (car l) a)
139. (member* a (cdr l))))
140. (t (or
141. (member* a (car l))
142. (member* a (cdr l))))))
143.
144. (defun eqlist? (l1 l2)
145. (cond
146. ((and (null l1) (null l2)) t)
147. ((or (null l1) (null l2)) NIL)
148. (t (and
149. (eq (car l1) (car l2))
150. (eqlist? (cdr l1) (cdr l2))))))
151.
152. (defun member_ (lista listb)
153. (cond
154. ((null lista) t)
155. ((null listb) NIL)
156. ((atom listb)
157. (eq lista listb))
158. ((atom lista)
159. (member* lista listb))
160. ((eqlist? lista listb) t)
161. (t (or (member_ lista (car listb))
162. (member_ lista (cdr listb))))))
163.
164. (defun subset? (set1 set2)
165. (cond
166. ((null set1) t)
167. ((member_ (car set1) set2)
168. (subset? (cdr set1) set2))
169. (t NIL)))
170.
171.
172. (defun union_ (set1 set2)
173. (cond
174. ((null set1) set2)
175. ((member_ (car set1) set2)
176. (union_ (cdr set1) set2))
177. (t (cons (car set1)
178. (union_ (cdr set1) set2)))))
179.
180. (defun rapply (rel x)
181. (cond
182. ((null rel) '())
183. ((null x) NIL)
184. ((and (rel? rel) (atom x))
185. (cond
186. ((eq (first_ (car rel)) x)
187. (cons (second_ (car rel)) (rapply (cdr rel) x)))
188. (t (rapply (cdr rel) x))))
189. (t NIL)))
190.
191. (defun lat? (l)
192. (cond
193. ((null l) t)
194. ((atom (car l)) (lat? (cdr l)))
195. (t nil)))
196.
197. (defun rin (x set)
198. (cond
199. ((null x) NIL)
200. ((null set) '())
201. ((lat? set)
202. (cons (build x (car set))
203. (rin x (cdr set))))
204. (t NIL)))
205.
206. (defun rcomp (rel1 rel2)
207. (cond
208. ((null rel1) '())
209. (t (union_ ;'union_
210. (rin
211. (first_ (car rel1))
212. (rapply rel2 (second_ (car rel1))))
213. (rcomp (cdr rel1) rel2)))))
214.
215. (defun transitive? (rel)
216. (subset? (rcomp rel rel) rel))
217.
218. (defun quasi-order? (rel)
219. (and (reflexive? rel) (transitive? rel)))
220.
221. (print (quasi-order? r1))
222. ;T
223.
224. (print (quasi-order? r3))
225. ;NIL false
226.
227. (defun intersect (set1 set2)
228. (cond
229. ((null set1) '())
230. ((not (member_ (car set1) set2))
231. (intersect (cdr set1) set2))
232. (t (cons (car set1)
233. (intersect (cdr set1) set2)))))
234.
235. (defun revrel (rel)
236. (cond
237. ((null rel) '())
238. (t (cons
239. (build
240. (second_ (car rel));_
241. (first_ (car rel)));_
242. (revrel (cdr rel))))))
243.
244. (defun antisymetric? (rel)
245. (subset? (intersect (revrel rel) rel) (idrel (domset rel))))
246.
247. (defun partial-order? (rel)
248. (and (quasi-order? rel) (antisymetric? rel)))
249.
250. (print (partial-order? r1))
251. ;T
252.
253. (print (partial-order? r3))
254. ;NIL false
255.
256. (defun eqset? (set1 set2)
257. (and
258. (subset? set1 set2)
259. (subset? set2 set1)))
260.
261.
262. (defun symmetric? (rel)
263. (eqset? rel (revrel rel)))
264.
265. (defun equivalence? (rel)
266. (and (quasi-order? rel) (symmetric? rel)))
267.
268. (print (equivalence? r1))
269. ;NIL false
270.
271. (print (equivalence? r2))
272. ;T
273.
Success #stdin #stdout 0.01s 10648KB
stdin
Standard input is empty
stdout
T
NIL
T
NIL
NIL
T