PageRenderTime 53ms CodeModel.GetById 23ms RepoModel.GetById 1ms app.codeStats 0ms

/gui.sc

http://github.com/qobi/R6RS-AD
Scala | 163 lines | 138 code | 25 blank | 0 comment | 1 complexity | d086efa0fd79e5ee650b36df05862c70 MD5 | raw file
Possible License(s): GPL-2.0
  1. ;;; scc -o gui -O2 gui.sc ~/lib/i686-Linux-2.6.26-2-686/QobiScheme.a ~/lib/i686-Linux-2.6.26-2-686/scxl.a -L /usr/X11R6/lib -lX11;rm gui.c;mv gui ~/bin/i686-Linux-2.6.26-2-686/.
  2. (module gui (with qobischeme xlib) (main main))
  3. (include "QobiScheme.sch")
  4. (set! *program* "gui")
  5. (set! *panic?* #t)
  6. (define-structure grid-point x y z)
  7. (define-structure grid-point-contents notches notch)
  8. (define *grid* #f)
  9. (define *theta* 0)
  10. (define *center* #f)
  11. (define *observer* '#(0 -40 100))
  12. (define *focal-length* 300)
  13. ;;; horizontal distance between notches
  14. (define *l1* 20)
  15. ;;; log radius
  16. (define *l2* 2)
  17. ;;; overhang
  18. (define *l3* 5)
  19. (define *i* 0)
  20. (define (grid-xy? grid-point) (even? (grid-point-y grid-point)))
  21. (define (grid-zy? grid-point) (odd? (grid-point-y grid-point)))
  22. (define (log->line-segment grid-point grid-point-contents)
  23. (cond
  24. ((grid-xy? grid-point)
  25. (make-line-segment
  26. (vector (- (* *l1* (grid-point-x grid-point)) *l3*)
  27. (* *l2* (grid-point-y grid-point))
  28. (* *l1* (grid-point-z grid-point)))
  29. (vector (+ (* *l1*
  30. (+ (grid-point-x grid-point)
  31. (- (grid-point-contents-notches grid-point-contents) 1)))
  32. *l3*)
  33. (* *l2* (grid-point-y grid-point))
  34. (* *l1* (grid-point-z grid-point)))))
  35. ((grid-zy? grid-point)
  36. (make-line-segment
  37. (vector (* *l1* (grid-point-x grid-point))
  38. (* *l2* (grid-point-y grid-point))
  39. (- (* *l1* (grid-point-z grid-point)) *l3*))
  40. (vector (* *l1* (grid-point-x grid-point))
  41. (* *l2* (grid-point-y grid-point))
  42. (+ (* *l1*
  43. (+ (grid-point-z grid-point)
  44. (- (grid-point-contents-notches grid-point-contents) 1)))
  45. *l3*))))
  46. (else (fuck-up))))
  47. (define (line-segments)
  48. (removeq
  49. #f
  50. (map (lambda (grid-element)
  51. (let ((grid-point (first grid-element))
  52. (grid-point-contents (second grid-element)))
  53. (if (and grid-point-contents
  54. ;; If the grid is malformed, i.e. if it does not meet the
  55. ;; occupancy constraints, it might display incorrectly.
  56. (zero? (grid-point-contents-notch grid-point-contents)))
  57. (log->line-segment grid-point grid-point-contents)
  58. #f)))
  59. *grid*)))
  60. (define (read-grid pathname)
  61. (map (lambda (string)
  62. (list (make-grid-point (string->number (field-ref string 0))
  63. (string->number (field-ref string 1))
  64. (string->number (field-ref string 2)))
  65. (if (zero? (string->number (field-ref string 3)))
  66. #f
  67. (make-grid-point-contents
  68. (string->number (field-ref string 3))
  69. (string->number (field-ref string 4))))))
  70. (read-file (default-extension pathname "logs"))))
  71. (define (object-center)
  72. (let ((line-segments (line-segments)))
  73. (if (null? line-segments)
  74. '#(0 0 0)
  75. (let ((v (k*v (/ (length line-segments))
  76. (reduce
  77. v+
  78. (map (lambda (l)
  79. (k*v 0.5 (v+ (line-segment-p l) (line-segment-q l))))
  80. line-segments)
  81. '#(0 0 0)))))
  82. (vector (x v) 0 (z v))))))
  83. (define (point-3d->2d p)
  84. (let ((theta (degrees->radians *theta*)))
  85. (project (v+ (m*v (vector (vector (cos theta) 0 (sin theta))
  86. (vector 0 1 0)
  87. (vector (- (sin theta)) 0 (cos theta)))
  88. (v- p *center*))
  89. *observer*)
  90. *focal-length*)))
  91. (define (line-segment-3d->2d l)
  92. (make-line-segment (point-3d->2d (line-segment-p l))
  93. (point-3d->2d (line-segment-q l))))
  94. (define-application viewer 640 480 #f 1 6
  95. (lambda ()
  96. (define-button 0 0 "Help" #f help-command)
  97. (define-button 5 0 "Quit" #f quit)
  98. (define-button 1 0 "+Theta" #f
  99. (lambda () (set! *theta* (+ *theta* 10)) (redraw-display-pane)))
  100. (define-button 2 0 "-Theta" #f
  101. (lambda () (set! *theta* (- *theta* 10)) (redraw-display-pane)))
  102. (define-button 3 0 "Next" #f
  103. (lambda ()
  104. (unless (can-open-file-for-input? (format #f "solution-~s.logs" (+ *i* 1)))
  105. (abort))
  106. (set! *i* (+ *i* 1))
  107. (set! *grid* (read-grid (format #f "solution-~s.logs" *i*)))
  108. (set! *center* (object-center))
  109. (redraw-display-pane)))
  110. (define-button 4 0 "Previous" #f
  111. (lambda ()
  112. (when (zero? *i*) (abort))
  113. (set! *i* (- *i* 1))
  114. (set! *grid* (read-grid (format #f "solution-~s.logs" *i*)))
  115. (set! *center* (object-center))
  116. (redraw-display-pane)))
  117. (define-key (list (control #\x) (control #\c)) "Quit" quit)
  118. (define-key (control #\h) "Help" help-command))
  119. (lambda () #f)
  120. (lambda () #f)
  121. (lambda ()
  122. (for-each (lambda (l)
  123. (let ((l (line-segment-3d->2d l)))
  124. (xdrawline *display* *display-pane* *thin-gc*
  125. (+ 320 (x (line-segment-p l)))
  126. (- 240 (y (line-segment-p l)))
  127. (+ 320 (x (line-segment-q l)))
  128. (- 240 (y (line-segment-q l))))))
  129. (line-segments))
  130. (xdrawstring
  131. *display* *display-pane* *roman-gc* 5 (- *display-pane-height* 5)
  132. (number->string *i*) (string-length (number->string *i*)))))
  133. (define (view)
  134. (set! *i* 0)
  135. (set! *grid* (read-grid (format #f "solution-~s.logs" *i*)))
  136. (set! *center* (object-center))
  137. (viewer '()))
  138. (define-command (main) (view))