server/gauche-tk.client.scm

@@ -3,36 +3,43 @@
   (scheme base)
   (scheme read)
   (scheme write)
+  (scheme inexact)
   (gauche threads)
   (srfi 180)
   (rfc http)
   (tk))
 
+(define pi 3.141592653589793)
+
 (define-record-type <turtle-action>
-  (turtle-action type pen-down? shown? x1 y1 x2 y2)
+  (turtle-action type pen-down? shown? x y x1 y1 x2 y2 color width facing)
   turtle-action?
   (type turtle-action-type)
   (pen-down? turtle-action-pen-down?)
   (shown? turtle-action-shown?)
+  (x turtle-action-x)
+  (y turtle-action-y)
   (x1 turtle-action-x1)
   (y1 turtle-action-y1)
   (x2 turtle-action-x2)
-  (y2 turtle-action-y2))
+  (y2 turtle-action-y2)
+  (color turtle-action-color)
+  (width turtle-action-width)
+  (facing turtle-action-facing))
 
 (define (json-object->turtle-action json-object)
-  (turtle-action
-   (string->symbol (cdr (assq 'type json-object)))
-   (cdr (assq 'penDown json-object))
-   (cdr (assq 'shown json-object))
-   (cdr (assq 'x1 json-object))
-   (cdr (assq 'y1 json-object))
-   (cdr (assq 'x2 json-object))
-   (cdr (assq 'y2 json-object))))
-
-(define scale-x 1.5)
-(define scale-y 1.5)
-(define displace-x 500)
-(define displace-y 500)
+  (define (safe-assq-ref l key)
+    (define result (assq key l))
+    (and result (cdr result)))
+  (define keys '(type penDown shown x y x1 y1 x2 y2 color width facing))
+  (apply turtle-action
+         (map (lambda (key) (safe-assq-ref json-object key))
+              keys)))
+
+(define scale-x 1.0)
+(define scale-y 1.0)
+(define displace-x 250)
+(define displace-y 250)
 (define bg-color #f)
 (define line-color #f)
 (define line-width #f)
@@ -44,13 +51,110 @@
   (define x2 (+ displace-x (* (turtle-action-x2 line-action) scale-x)))
   (define y2 (- displace-y (* (turtle-action-y2 line-action) scale-y)))
 
-  (draw-line-action-real-tk-action line-color line-width x1 y1 x2 y2))
+  (tk-call '.canvas
+           'create
+           'line
+           x1
+           y1
+           x2
+           y2
+           '-fill
+           line-color
+           '-width
+           line-width))
+
+(define (redraw-turtle! line-action)
+  (define x (+ displace-x (* (turtle-action-x line-action) scale-x)))
+  (define y (- displace-y (* (turtle-action-y line-action) scale-y)))
+  (define theta-deg (turtle-action-facing line-action))
+  (define theta (- (* theta-deg (/ 3.141592653589792 180))))
+  (define turtle-size 24)
+  (define (draw-circle x y size tags)
+    (tk-call '.canvas
+             'create
+             'oval
+             (- x (/ size 2.0))
+             (- y (/ size 2.0))
+             (+ x (/ size 2.0))
+             (+ y (/ size 2.0))
+             '-tags
+             tags
+             '-fill
+             line-color))
+                                        ; Delete any previous turtles
+  (tk-call '.canvas 'delete 'turtle)
+                                        ; Create the body
+  (draw-circle x y turtle-size "turtle")
+                                        ; Create the head
+  (draw-circle (+ x (* 0.75 turtle-size (cos theta)))
+               (+ y (* 0.75 turtle-size (sin theta)))
+               (/ turtle-size 2)
+               "turtle")
+                                        ; Create the front legs
+  (draw-circle (+ x (* 0.625 turtle-size (cos (+ theta 0.785))))
+               (+ y (* 0.625 turtle-size (sin (+ theta 0.785))))
+               (/ turtle-size 4)
+               "turtle")
+  (draw-circle (+ x (* 0.625 turtle-size (cos (- theta 0.785))))
+               (+ y (* 0.625 turtle-size (sin (- theta 0.785))))
+               (/ turtle-size 4)
+               "turtle")
+                                        ; Create the rear legs
+  (draw-circle (+ x (* 0.625 turtle-size (cos (+ theta 2.356))))
+               (+ y (* 0.625 turtle-size (sin (+ theta 2.356))))
+               (/ turtle-size 4)
+               "turtle")
+  (draw-circle (+ x (* 0.625 turtle-size (cos (- theta 2.356))))
+               (+ y (* 0.625 turtle-size (sin (- theta 2.356))))
+               (/ turtle-size 4)
+               "turtle"))
+
+(define (clear-all!)
+  (tk-call '.canvas 'delete "all"))
 
 (define (draw-turtle-line! line-action)
-  (draw-line! line-action))
+  (define x1 (* (turtle-action-x1 line-action)))
+  (define y1 (* (turtle-action-y1 line-action)))
+  (define x2 (* (turtle-action-x2 line-action)))
+  (define y2 (* (turtle-action-y2 line-action)))
+
+  (define dy (- y2 y1))
+  (define dx (- x2 x1))
+
+  (define facing-amount-base (/ (* 180 (atan (/ dy dx))) pi))
+
+  (define facing-amount (if (> x1 x2)
+                            (+ facing-amount-base 180)
+                            (+ facing-amount-base 360)))
+
+  (cond
+   ((turtle-action-shown? line-action)
+    (draw-line! line-action)
+    (redraw-turtle! (json-object->turtle-action `((x . ,(turtle-action-x2 line-action))
+                                                  (y . ,(turtle-action-y2 line-action))
+                                                  (facing . ,facing-amount)))))
+   (else
+    (draw-line! line-action))))
+
+(define (delete-turtle!)
+  #f)
+
+(define (set-bg-color! instruction)
+  (define color (turtle-action-color instruction))
+  (tk-call '.canvas
+           'configure
+           '-bg
+           color)
+  (set! bg-color color))
+
+(define (set-line-color! instruction)
+  (set! line-color (turtle-action-color instruction)))
+
+(define (set-line-width! instruction)
+  (set! line-width (turtle-action-width instruction)))
 
 (define (turtle-do! instruction)
-  (case (turtle-action-type instruction)
+  (case (string->symbol (turtle-action-type instruction))
     ((line)
      (draw-line! instruction))
     ((turtleLine)
@@ -81,22 +185,25 @@
   (let ((p (open-input-string new-id-json)))
     (define new-id (json-read p))
     (close-input-port p)
-    (set! page-id (string->number new-id))
-    (write page-id)
-    (newline)))
+    (set! page-id (string->number new-id))))
 
 (define (on-interval!)
   (define-values (status-code response-header turtle-json) (http-post json-source-server json-source-path (number->string page-id)))
   (let ((p (open-input-string turtle-json)))
     (define turtle-json-raw (json-read p))
     (close-input-port p)
-    (write turtle-json-raw)
     (vector-for-each turtle-do! (vector-map json-object->turtle-action turtle-json-raw))))
 
 (get-session-id!)
 (tk-init '())
 (tk-wm 'title "." "turtle")
-(tk-grid (tk-canvas '.canvas '-width 1000 '-height 1000 '-bg 'black))
+(tk-grid (tk-canvas '.canvas '-width 600 '-height 600 '-bg 'black))
+
+(set-bg-color! (json-object->turtle-action '((color . "black"))))
+(set-line-color! (json-object->turtle-action '((color . "white"))))
+(set-line-width! (json-object->turtle-action '((width . 1.0))))
+
 (let loop ()
   (on-interval!)
-  (thread-sleep! 0.5))
+  (thread-sleep! 0.5)
+  (loop))