156 lines
4.0 KiB
Plaintext
Executable File
156 lines
4.0 KiB
Plaintext
Executable File
;; Tuple examples - demonstrating Factor-style BOA construction
|
|
|
|
;; Define a 2D point tuple (no arrow = tuple definition)
|
|
(define point (x float) (y float))
|
|
|
|
;; Note: make-point constructor is auto-generated
|
|
;; Stack effect: (float float -> point)
|
|
|
|
(define origin ( -> point)
|
|
(0.0 0.0 make-point)) ; Stack: [] → [point{x:0.0, y:0.0}]
|
|
|
|
(define unit-x ( -> point)
|
|
(1.0 0.0 make-point)) ; point{x:1.0, y:0.0}
|
|
|
|
;; Accessing fields
|
|
(define get-x (point -> float)
|
|
(.x)) ; Extract x field
|
|
|
|
(define get-y (point -> float)
|
|
(.y)) ; Extract y field
|
|
|
|
;; Pattern matching destructures in order
|
|
(define point-magnitude (point -> float)
|
|
(match
|
|
((point x y) → ; Pushes x, then y onto stack
|
|
x dup * ; x²
|
|
y dup * ; y²
|
|
+ sqrt))) ; √(x² + y²)
|
|
|
|
;; Functional update (creates new tuple)
|
|
(define move-x (point float -> make-point)
|
|
(swap ; [point dx]
|
|
dup .x ; [point dx x]
|
|
rot + ; [point x']
|
|
swap .y ; [x' point y]
|
|
swap ; [x' y point]
|
|
drop ; [x' y]
|
|
make-point)) ; Reconstruct with new x
|
|
|
|
;; Or using update syntax
|
|
(define move-x-v2 (point float -> make-point)
|
|
(over .x + ; Calculate new x
|
|
swap .y ; Get old y
|
|
make-point)) ; Reconstruct
|
|
|
|
;; Complex tuple
|
|
(define person
|
|
(name string)
|
|
(age int)
|
|
(email string))
|
|
|
|
;; Example person (uses auto-generated make-person)
|
|
(define alice ( -> person)
|
|
("Alice" 30 "alice@example.com" make-person))
|
|
|
|
;; Accessor
|
|
(define person-name (person -> string)
|
|
(.name))
|
|
|
|
;; Pattern match all fields
|
|
(define person-info (person -> )
|
|
(match
|
|
((person name age email) →
|
|
"Name: " display name display
|
|
", Age: " display age display
|
|
", Email: " display email display)))
|
|
|
|
;; Nested tuples
|
|
(define rect
|
|
(top-left point)
|
|
(bottom-right point))
|
|
|
|
;; Create rectangle from coordinates
|
|
(define make-rect (float float float float -> rect)
|
|
(make-point ; Construct bottom-right
|
|
swap rot swap ; Shuffle for top-left
|
|
make-point ; Construct top-left
|
|
swap ; Swap to correct order
|
|
make-rect)) ; Construct rectangle
|
|
|
|
;; Calculate rectangle area
|
|
(define rect-area (rect -> float)
|
|
(match
|
|
((rect (point x1 y1) (point x2 y2)) →
|
|
x2 x1 - abs
|
|
y2 y1 - abs
|
|
*)))
|
|
|
|
;; Generic operations on tuples
|
|
(define vec2
|
|
(x float)
|
|
(y float))
|
|
|
|
;; Add two vectors using BOA
|
|
(define vec2-add (vec2 vec2 -> vec2)
|
|
(match
|
|
((vec2 x2 y2) → ; Destructure second (top of stack)
|
|
(match
|
|
((vec2 x1 y1) → ; Destructure first
|
|
x1 x2 + ; Add x components
|
|
y1 y2 + ; Add y components
|
|
make-vec2))))) ; BOA reconstruction
|
|
|
|
;; Alternative: use slot access
|
|
(define vec2-add-v2 (vec2 vec2 -> vec2)
|
|
(over .x over .x + ; Add x's
|
|
rot .y rot .y + ; Add y's
|
|
make-vec2)) ; Reconstruct
|
|
|
|
;; Scalar multiplication
|
|
(define vec2-scale (vec2 float -> vec2)
|
|
(swap
|
|
match
|
|
((vec2 x y) →
|
|
rot ; [x y scalar]
|
|
dup rot * ; [scalar x*scalar y]
|
|
swap rot * ; [x*scalar y*scalar]
|
|
make-vec2)))
|
|
|
|
;; Dot product
|
|
(define vec2-dot (vec2 vec2 -> float)
|
|
(match
|
|
((vec2 x2 y2) →
|
|
(match
|
|
((vec2 x1 y1) →
|
|
x1 x2 *
|
|
y1 y2 *
|
|
+)))))
|
|
|
|
;; Three-component vector
|
|
(define vec3
|
|
(x float)
|
|
(y float)
|
|
(z float))
|
|
|
|
;; Cross product
|
|
(define vec3-cross (vec3 vec3 -> vec3)
|
|
(match
|
|
((vec3 bx by bz) →
|
|
(match
|
|
((vec3 ax ay az) →
|
|
ay bz * az by * - ; cx
|
|
az bx * ax bz * - ; cy
|
|
ax by * ay bx * - ; cz
|
|
make-vec3)))))
|
|
|
|
;; Anonymous tuples (quick pairs, triples)
|
|
(define swap-pair ((tuple 'a 'b) -> (tuple 'b 'a))
|
|
(match
|
|
((tuple x y) → y x tuple2)))
|
|
|
|
;; Three-way rotation
|
|
(define rot3 ((tuple 'a 'b 'c) -> (tuple 'b 'c 'a))
|
|
(match
|
|
((tuple x y z) → y z x tuple3)))
|