giles
0e426cfea8
- lib/common-lisp/clos.sx (27 forms): class registry (8 built-in classes), defclass/make-instance/slot-value/slot-boundp/change-class, defgeneric/defmethod with :before/:after/:around, clos-call-generic (standard combination: sort by specificity, fire befores, call primary chain, fire afters reversed), call-next-method/next-method-p, with-slots, deferred accessor installation - lib/common-lisp/tests/clos.sx: 41 tests (class-of, subclass-of?, defclass, make-instance, slot ops, inheritance, method specificity, qualifiers, accessors, with-slots, change-class) - lib/common-lisp/tests/programs/geometry.sx: 12 tests — intersect generic dispatching on geo-point×geo-point, geo-point×geo-line, geo-line×geo-line, geo-line×geo-plane (multi-dispatch by class precedence) - lib/common-lisp/tests/programs/mop-trace.sx: 13 tests — :before/:after tracing on area and describe-shape generics, call-next-method in circle/rect - eval.sx: dynamic variables — cl-apply-dyn saves/restores global slot for specials; cl-mark-special!/cl-special?/cl-dyn-unbound; defvar now marks specials; let/let* rebind via cl-apply-dyn; 8 new tests (182 eval total) - conformance.sh + test.sh: Phase 4 suites wired in - plans/common-lisp-on-sx.md: Phase 4 + dynamic variable boxes ticked Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
291 lines
8.2 KiB
Plaintext
291 lines
8.2 KiB
Plaintext
;; geometry.sx — Multiple dispatch with CLOS
|
||
;;
|
||
;; Demonstrates generic functions dispatching on combinations of
|
||
;; geometric types: point, line, plane.
|
||
;;
|
||
;; Depends on: lib/common-lisp/runtime.sx, lib/common-lisp/clos.sx
|
||
|
||
;; ── geometric classes ──────────────────────────────────────────────────────
|
||
|
||
(clos-defclass "geo-point" (list "t") (list {:initform 0 :initarg ":px" :reader nil :writer nil :accessor nil :name "px"} {:initform 0 :initarg ":py" :reader nil :writer nil :accessor nil :name "py"}))
|
||
|
||
(clos-defclass "geo-line" (list "t") (list {:initform nil :initarg ":p1" :reader nil :writer nil :accessor nil :name "p1"} {:initform nil :initarg ":p2" :reader nil :writer nil :accessor nil :name "p2"}))
|
||
|
||
(clos-defclass "geo-plane" (list "t") (list {:initform nil :initarg ":normal" :reader nil :writer nil :accessor nil :name "normal"} {:initform 0 :initarg ":d" :reader nil :writer nil :accessor nil :name "d"}))
|
||
|
||
;; ── helpers ────────────────────────────────────────────────────────────────
|
||
|
||
(define geo-point-x (fn (p) (clos-slot-value p "px")))
|
||
(define geo-point-y (fn (p) (clos-slot-value p "py")))
|
||
|
||
(define
|
||
geo-make-point
|
||
(fn (x y) (clos-make-instance "geo-point" ":px" x ":py" y)))
|
||
|
||
(define
|
||
geo-make-line
|
||
(fn (p1 p2) (clos-make-instance "geo-line" ":p1" p1 ":p2" p2)))
|
||
|
||
(define
|
||
geo-make-plane
|
||
(fn
|
||
(nx ny d)
|
||
(clos-make-instance "geo-plane" ":normal" (list nx ny) ":d" d)))
|
||
|
||
;; ── describe generic ───────────────────────────────────────────────────────
|
||
|
||
(clos-defgeneric "geo-describe" {})
|
||
|
||
(clos-defmethod
|
||
"geo-describe"
|
||
(list)
|
||
(list "geo-point")
|
||
(fn
|
||
(args next-fn)
|
||
(let
|
||
((p (first args)))
|
||
(str "P(" (geo-point-x p) "," (geo-point-y p) ")"))))
|
||
|
||
(clos-defmethod
|
||
"geo-describe"
|
||
(list)
|
||
(list "geo-line")
|
||
(fn
|
||
(args next-fn)
|
||
(let
|
||
((l (first args)))
|
||
(str
|
||
"L["
|
||
(clos-call-generic "geo-describe" (list (clos-slot-value l "p1")))
|
||
"-"
|
||
(clos-call-generic "geo-describe" (list (clos-slot-value l "p2")))
|
||
"]"))))
|
||
|
||
(clos-defmethod
|
||
"geo-describe"
|
||
(list)
|
||
(list "geo-plane")
|
||
(fn
|
||
(args next-fn)
|
||
(let
|
||
((pl (first args)))
|
||
(str "Plane(d=" (clos-slot-value pl "d") ")"))))
|
||
|
||
;; ── intersect: multi-dispatch generic ─────────────────────────────────────
|
||
;;
|
||
;; Returns a string description of the intersection result.
|
||
|
||
(clos-defgeneric "intersect" {})
|
||
|
||
;; point ∩ point: same if coordinates match
|
||
(clos-defmethod
|
||
"intersect"
|
||
(list)
|
||
(list "geo-point" "geo-point")
|
||
(fn
|
||
(args next-fn)
|
||
(let
|
||
((p1 (first args)) (p2 (first (rest args))))
|
||
(if
|
||
(and
|
||
(= (geo-point-x p1) (geo-point-x p2))
|
||
(= (geo-point-y p1) (geo-point-y p2)))
|
||
"point"
|
||
"empty"))))
|
||
|
||
;; point ∩ line: check if point lies on line (cross product = 0)
|
||
(clos-defmethod
|
||
"intersect"
|
||
(list)
|
||
(list "geo-point" "geo-line")
|
||
(fn
|
||
(args next-fn)
|
||
(let
|
||
((pt (first args)) (ln (first (rest args))))
|
||
(let
|
||
((lp1 (clos-slot-value ln "p1")) (lp2 (clos-slot-value ln "p2")))
|
||
(let
|
||
((dx (- (geo-point-x lp2) (geo-point-x lp1)))
|
||
(dy (- (geo-point-y lp2) (geo-point-y lp1)))
|
||
(ex (- (geo-point-x pt) (geo-point-x lp1)))
|
||
(ey (- (geo-point-y pt) (geo-point-y lp1))))
|
||
(if (= (- (* dx ey) (* dy ex)) 0) "point" "empty"))))))
|
||
|
||
;; line ∩ line: parallel (same slope = empty) or point
|
||
(clos-defmethod
|
||
"intersect"
|
||
(list)
|
||
(list "geo-line" "geo-line")
|
||
(fn
|
||
(args next-fn)
|
||
(let
|
||
((l1 (first args)) (l2 (first (rest args))))
|
||
(let
|
||
((p1 (clos-slot-value l1 "p1"))
|
||
(p2 (clos-slot-value l1 "p2"))
|
||
(p3 (clos-slot-value l2 "p1"))
|
||
(p4 (clos-slot-value l2 "p2")))
|
||
(let
|
||
((dx1 (- (geo-point-x p2) (geo-point-x p1)))
|
||
(dy1 (- (geo-point-y p2) (geo-point-y p1)))
|
||
(dx2 (- (geo-point-x p4) (geo-point-x p3)))
|
||
(dy2 (- (geo-point-y p4) (geo-point-y p3))))
|
||
(let
|
||
((cross (- (* dx1 dy2) (* dy1 dx2))))
|
||
(if (= cross 0) "parallel" "point")))))))
|
||
|
||
;; line ∩ plane: general case = point (or parallel if line ⊥ normal)
|
||
(clos-defmethod
|
||
"intersect"
|
||
(list)
|
||
(list "geo-line" "geo-plane")
|
||
(fn
|
||
(args next-fn)
|
||
(let
|
||
((ln (first args)) (pl (first (rest args))))
|
||
(let
|
||
((p1 (clos-slot-value ln "p1"))
|
||
(p2 (clos-slot-value ln "p2"))
|
||
(n (clos-slot-value pl "normal")))
|
||
(let
|
||
((dx (- (geo-point-x p2) (geo-point-x p1)))
|
||
(dy (- (geo-point-y p2) (geo-point-y p1)))
|
||
(nx (first n))
|
||
(ny (first (rest n))))
|
||
(let
|
||
((dot (+ (* dx nx) (* dy ny))))
|
||
(if (= dot 0) "parallel" "point")))))))
|
||
|
||
;; ── tests ─────────────────────────────────────────────────────────────────
|
||
|
||
(define passed 0)
|
||
(define failed 0)
|
||
(define failures (list))
|
||
|
||
(define
|
||
check
|
||
(fn
|
||
(label got expected)
|
||
(if
|
||
(= got expected)
|
||
(set! passed (+ passed 1))
|
||
(begin
|
||
(set! failed (+ failed 1))
|
||
(set!
|
||
failures
|
||
(append
|
||
failures
|
||
(list
|
||
(str
|
||
"FAIL ["
|
||
label
|
||
"]: got="
|
||
(inspect got)
|
||
" expected="
|
||
(inspect expected)))))))))
|
||
|
||
;; describe
|
||
(check
|
||
"describe point"
|
||
(clos-call-generic
|
||
"geo-describe"
|
||
(list (geo-make-point 3 4)))
|
||
"P(3,4)")
|
||
(check
|
||
"describe line"
|
||
(clos-call-generic
|
||
"geo-describe"
|
||
(list
|
||
(geo-make-line
|
||
(geo-make-point 0 0)
|
||
(geo-make-point 1 1))))
|
||
"L[P(0,0)-P(1,1)]")
|
||
(check
|
||
"describe plane"
|
||
(clos-call-generic
|
||
"geo-describe"
|
||
(list (geo-make-plane 0 1 5)))
|
||
"Plane(d=5)")
|
||
|
||
;; intersect point×point
|
||
(check
|
||
"P∩P same"
|
||
(clos-call-generic
|
||
"intersect"
|
||
(list
|
||
(geo-make-point 2 3)
|
||
(geo-make-point 2 3)))
|
||
"point")
|
||
(check
|
||
"P∩P diff"
|
||
(clos-call-generic
|
||
"intersect"
|
||
(list
|
||
(geo-make-point 1 2)
|
||
(geo-make-point 3 4)))
|
||
"empty")
|
||
|
||
;; intersect point×line
|
||
(let
|
||
((origin (geo-make-point 0 0))
|
||
(p10 (geo-make-point 10 0))
|
||
(p55 (geo-make-point 5 5))
|
||
(l-x
|
||
(geo-make-line
|
||
(geo-make-point 0 0)
|
||
(geo-make-point 10 0))))
|
||
(begin
|
||
(check
|
||
"P∩L on line"
|
||
(clos-call-generic "intersect" (list p10 l-x))
|
||
"point")
|
||
(check
|
||
"P∩L on x-axis"
|
||
(clos-call-generic "intersect" (list origin l-x))
|
||
"point")
|
||
(check
|
||
"P∩L off line"
|
||
(clos-call-generic "intersect" (list p55 l-x))
|
||
"empty")))
|
||
|
||
;; intersect line×line
|
||
(let
|
||
((horiz (geo-make-line (geo-make-point 0 0) (geo-make-point 10 0)))
|
||
(vert
|
||
(geo-make-line
|
||
(geo-make-point 5 -5)
|
||
(geo-make-point 5 5)))
|
||
(horiz2
|
||
(geo-make-line
|
||
(geo-make-point 0 3)
|
||
(geo-make-point 10 3))))
|
||
(begin
|
||
(check
|
||
"L∩L crossing"
|
||
(clos-call-generic "intersect" (list horiz vert))
|
||
"point")
|
||
(check
|
||
"L∩L parallel"
|
||
(clos-call-generic "intersect" (list horiz horiz2))
|
||
"parallel")))
|
||
|
||
;; intersect line×plane
|
||
(let
|
||
((diag (geo-make-line (geo-make-point 0 0) (geo-make-point 1 1)))
|
||
(vert-plane (geo-make-plane 1 0 5))
|
||
(diag-plane (geo-make-plane -1 1 0)))
|
||
(begin
|
||
(check
|
||
"L∩Plane cross"
|
||
(clos-call-generic "intersect" (list diag vert-plane))
|
||
"point")
|
||
(check
|
||
"L∩Plane parallel"
|
||
(clos-call-generic "intersect" (list diag diag-plane))
|
||
"parallel")))
|
||
|
||
;; ── summary ────────────────────────────────────────────────────────────────
|
||
|
||
(define geo-passed passed)
|
||
(define geo-failed failed)
|
||
(define geo-failures failures) |