Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- (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)))
- ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- )
Add Comment
Please, Sign In to add comment