pt-class.sls

(library (pt-class)

  (export make-pt is-pt pt::norm pt/n pt::normalize)

  (import (rnrs)
	  (dharmalab misc gen-id))

  (define-record-type pt
    (fields (mutable x)
	    (mutable y)))

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define-syntax import-pt

    (lambda (stx)

      (syntax-case stx ()

	((import-pt p)

	 (with-syntax ( (x (gen-id #'p "x"))
			(y (gen-id #'p "y"))

			(x! (gen-id #'p "x!"))
			(y! (gen-id #'p "y!"))

			(neg       (gen-id #'p "neg"))
			(norm      (gen-id #'p "norm"))
			(normalize (gen-id #'p "normalize")) )

	   #'(begin

	       (define-syntax x
		 (identifier-syntax
		  (pt-x p)))

	       (define-syntax y
		 (identifier-syntax
		  (pt-y p)))

	       (define-syntax x!
		 (syntax-rules ()
		   ((x! val)
		    (pt-x-set! p val))))

	       (define-syntax y!
		 (syntax-rules ()
		   ((y! val)
		    (pt-y-set! p val))))

	       (define-syntax neg
		 (syntax-rules ()
		   ((neg)
		    (pt::neg p))))

	       (define-syntax norm
		 (syntax-rules ()
		   ((norm)
		    (pt::norm p))))

	       (define-syntax normalize
		 (syntax-rules ()
		   ((normalize)
		    (pt::normalize p))))))))))

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define-syntax is-pt

    (lambda (stx)

      (syntax-case stx ()

	((is-pt p)

	 (with-syntax ( (p.x (gen-id #'p #'p ".x"))
			(p.y (gen-id #'p #'p ".y"))

			(p.x! (gen-id #'p #'p ".x!"))
			(p.y! (gen-id #'p #'p ".y!"))

			(p.neg       (gen-id #'p #'p ".neg"))
			(p.norm      (gen-id #'p #'p ".norm"))
			(p.normalize (gen-id #'p #'p ".normalize")) )

	   #'(begin

	       (define-syntax p.x
		 (identifier-syntax
		  (pt-x p)))

	       (define-syntax p.y
		 (identifier-syntax
		  (pt-y p)))

	       (define-syntax p.x!
		 (syntax-rules ()
		   ((p.x! val)
		    (pt-x-set! p val))))

	       (define-syntax p.y!
		 (syntax-rules ()
		   ((p.y! val)
		    (pt-y-set! p val))))

	       (define-syntax p.neg
		 (syntax-rules ()
		   ((p.neg)
		    (pt::neg p))))

	       (define-syntax p.norm
		 (syntax-rules ()
		   ((p.norm)
		    (pt::norm p))))

	       (define-syntax p.normalize
		 (syntax-rules ()
		   ((p.normalize)
		    (pt::normalize p))))))))))

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define (sq x) (* x x))

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define (pt::norm p)

    (import-pt p)

    (sqrt (+ (sq x)
	     (sq y))))

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define (pt/n p n)

    (is-pt p)

    (make-pt (/ p.x n)
	     (/ p.y n)))

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define (pt::normalize p)

    (import-pt p)

    (pt/n p (norm)))

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  )