prescheme-demo/recfun.scm

;;; recfun: an example Pre-Scheme program

(define-record-type vec2 :vec2
  (%make-vec2 x y)
  (x integer vec2-x)
  (y integer vec2-y))

(define-syntax vec2
  (syntax-rules ()
    ((vec2 x y)
     (%make-vec2 x y))))

(define (vec2+ a b)
  (vec2 (+ (vec2-x a) (vec2-x b))
        (+ (vec2-y a) (vec2-y b))))

(define (vec2- a b)
  (vec2 (- (vec2-x a) (vec2-x b))
        (- (vec2-y a) (vec2-y b))))

(define (write-vec2 a port)
  (write-string "#<vec2 " port)
  (write-integer (vec2-x a) port)
  (write-char #\space port)
  (write-integer (vec2-y a) port)
  (write-char #\> port))

(define-record-type rect :rect
  (%make-rect tl wh)
  (tl vec2 %rect-tl)
  (wh vec2 %rect-wh))

(define-syntax rect
  (syntax-rules ()
    ((rect x y w h)
     (%make-rect (vec2 x y) (vec2 w h)))))

(define (rect-left a)   (vec2-x (%rect-tl a)))
(define (rect-top a)    (vec2-y (%rect-tl a)))
(define (rect-width a)  (vec2-x (%rect-wh a)))
(define (rect-height a) (vec2-y (%rect-wh a)))

(define (rect-bottom a) (+ (rect-top a) (rect-height a)))
(define (rect-right a)  (+ (rect-left a) (rect-width a)))

(define (rect-top-left a)     (vec2 (rect-left a) (rect-top a)))
(define (rect-top-right a)    (vec2 (rect-right a) (rect-top a)))
(define (rect-bottom-left a)  (vec2 (rect-left a) (rect-bottom a)))
(define (rect-bottom-right a) (vec2 (rect-right a) (rect-bottom a)))

(define (write-rect a port)
  (write-string "#<rect " port)
  (write-integer (rect-left a) port)
  (write-char #\space port)
  (write-integer (rect-top a) port)
  (write-char #\space port)
  (write-integer (rect-width a) port)
  (write-char #\space port)
  (write-integer (rect-height a) port)
  (write-char #\> port))

(define (main)
  (define out (current-output-port))

  (let ((a (rect 10 10 2 2))
        (write-corner (lambda (name corner out)
                        (write-string name out)
                        (write-string ": " out)
                        (write-vec2 corner out)
                        (newline out)
                        (deallocate corner)
                        (unspecific))))
    (write-rect a out)
    (newline out)
    (write-corner "top-left" (rect-top-left a) out)
    (write-corner "top-right" (rect-top-right a) out)
    (write-corner "bottom-left" (rect-bottom-left a) out)
    (write-corner "bottom-right" (rect-bottom-right a) out))

  0)