Guest User

Untitled

a guest
May 16th, 2018
121
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 2.78 KB | None | 0 0
  1. (library (pt-class)
  2.  
  3. (export make-pt is-pt pt::norm pt/n pt::normalize)
  4.  
  5. (import (rnrs)
  6. (dharmalab misc gen-id))
  7.  
  8. (define-record-type pt
  9. (fields (mutable x)
  10. (mutable y)))
  11.  
  12. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (define-syntax import-pt
  15.  
  16. (lambda (stx)
  17.  
  18. (syntax-case stx ()
  19.  
  20. ((import-pt p)
  21.  
  22. (with-syntax ( (x (gen-id #'p "x"))
  23. (y (gen-id #'p "y"))
  24.  
  25. (x! (gen-id #'p "x!"))
  26. (y! (gen-id #'p "y!"))
  27.  
  28. (neg (gen-id #'p "neg"))
  29. (norm (gen-id #'p "norm"))
  30. (normalize (gen-id #'p "normalize")) )
  31.  
  32. #'(begin
  33.  
  34. (define-syntax x
  35. (identifier-syntax
  36. (pt-x p)))
  37.  
  38. (define-syntax y
  39. (identifier-syntax
  40. (pt-y p)))
  41.  
  42. (define-syntax x!
  43. (syntax-rules ()
  44. ((x! val)
  45. (pt-x-set! p val))))
  46.  
  47. (define-syntax y!
  48. (syntax-rules ()
  49. ((y! val)
  50. (pt-y-set! p val))))
  51.  
  52. (define-syntax neg
  53. (syntax-rules ()
  54. ((neg)
  55. (pt::neg p))))
  56.  
  57. (define-syntax norm
  58. (syntax-rules ()
  59. ((norm)
  60. (pt::norm p))))
  61.  
  62. (define-syntax normalize
  63. (syntax-rules ()
  64. ((normalize)
  65. (pt::normalize p))))))))))
  66.  
  67. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  68.  
  69. (define-syntax is-pt
  70.  
  71. (lambda (stx)
  72.  
  73. (syntax-case stx ()
  74.  
  75. ((is-pt p)
  76.  
  77. (with-syntax ( (p.x (gen-id #'p #'p ".x"))
  78. (p.y (gen-id #'p #'p ".y"))
  79.  
  80. (p.x! (gen-id #'p #'p ".x!"))
  81. (p.y! (gen-id #'p #'p ".y!"))
  82.  
  83. (p.neg (gen-id #'p #'p ".neg"))
  84. (p.norm (gen-id #'p #'p ".norm"))
  85. (p.normalize (gen-id #'p #'p ".normalize")) )
  86.  
  87. #'(begin
  88.  
  89. (define-syntax p.x
  90. (identifier-syntax
  91. (pt-x p)))
  92.  
  93. (define-syntax p.y
  94. (identifier-syntax
  95. (pt-y p)))
  96.  
  97. (define-syntax p.x!
  98. (syntax-rules ()
  99. ((p.x! val)
  100. (pt-x-set! p val))))
  101.  
  102. (define-syntax p.y!
  103. (syntax-rules ()
  104. ((p.y! val)
  105. (pt-y-set! p val))))
  106.  
  107. (define-syntax p.neg
  108. (syntax-rules ()
  109. ((p.neg)
  110. (pt::neg p))))
  111.  
  112. (define-syntax p.norm
  113. (syntax-rules ()
  114. ((p.norm)
  115. (pt::norm p))))
  116.  
  117. (define-syntax p.normalize
  118. (syntax-rules ()
  119. ((p.normalize)
  120. (pt::normalize p))))))))))
  121.  
  122. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  123.  
  124. (define (sq x) (* x x))
  125.  
  126. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  127.  
  128. (define (pt::norm p)
  129.  
  130. (import-pt p)
  131.  
  132. (sqrt (+ (sq x)
  133. (sq y))))
  134.  
  135. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  136.  
  137. (define (pt/n p n)
  138.  
  139. (is-pt p)
  140.  
  141. (make-pt (/ p.x n)
  142. (/ p.y n)))
  143.  
  144. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  145.  
  146. (define (pt::normalize p)
  147.  
  148. (import-pt p)
  149.  
  150. (pt/n p (norm)))
  151.  
  152. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  153.  
  154. )
Add Comment
Please, Sign In to add comment