turtle-r7rs/web-client.scm

(define-record-type <canvas>
  (make-canvas params)
  canvas?
  (params get-params))

(define current-canvas (make-canvas '((uri-root . "localhost:43334"))))

(define (set-canvas! new-canvas)
  (set! current-canvas new-canvas))

(define (send-to-canvas! uri-path obj)
  (when (or (not (canvas? current-canvas))
            (not (pair? (get-params current-canvas))))
    (error "current-canvas does not have valid parameters"))
  (let ((param-list (get-params current-canvas)))
    (let ((uri-root-pair (assq 'uri-root param-list)))
      (unless uri-root-pair
        (error "current-canvas does not have required key uri-root"))
      (make-post-request (cdr uri-root-pair) "/api/PushBuffer" obj))))

(define color-mapping
  '((black . "#000")
    (gray . "#808080")
    (red . "#f00")
    (darkred . "#8b0000")
    (lime . "#0f0")
    (green . "#008000")
    (darkgreen . "#006400")
    (blue . "#00f")
    (darkblue . "#00008b")
    (cyan . "#0ff")
    (darkcyan . "#008b8b")
    (magenta . "#f0f")
    (darkmagenta . "#8b008b")
    (yellow . "#ff0")
    (goldenrod "#daa520")
    (white . "#fff")))

(define (push-buffer! instruction)
  (let ((p (open-output-string)))
    (write instruction p)
    (let ((result (get-output-string p)))
      (close-output-port p)
      (send-to-canvas! "/api/PushBuffer" result)))
  ;; to prevent the buffer from growing too quickly
  (wait-a-moment!))

(define (make-line x1 y1 x2 y2)
  `((type . "line")
    (x1 . ,x1)
    (y1 . ,y1)
    (x2 . ,x2)
    (y2 . ,y2)))

(define (make-turtle-line x1 y1 x2 y2 pen-down shown)
  `((type . "turtleLine")
    (penDown . ,pen-down)
    (shown . ,shown)
    (x1 . ,x1)
    (y1 . ,y1)
    (x2 . ,x2)
    (y2 . ,y2)))

(define (draw-line x1 y1 x2 y2)
  ;; TODO: ensure arguments are numbers
  (push-buffer! (make-line x1 y1 x2 y2)))

(define (draw-turtle-line x1 y1 x2 y2 pen-down shown)
  (push-buffer! (make-turtle-line x1 y1 x2 y2 pen-down shown)))

(define clear-screen
  (case-lambda
    (()
     (push-buffer! '((type . "clear"))))
    ((sym)
     (push-buffer! '((type . "clear")))
     (when (eq? sym 'complete)
       (make-post-request "localhost:43334" "/api/ClearBuffer" "")))))

(define (canvas-image-rotate x y theta1 delta-theta)
  (push-buffer! `((type . "rotate")
                  (x . ,x)
                  (y . ,y)
                  (facing . ,(+ theta1 delta-theta)))))

(define (canvas-bg-color color)
  (let ((color-pair (assq color color-mapping)))
    (unless color-pair
      (error "bg-color" "Not a valid color" color))
    (push-buffer! `((type . "bgColor")
                    (color . ,(cdr color-pair))))))

(define (canvas-line-color color)
  (let ((color-pair (assq color color-mapping)))
    (unless color-pair
      (error "line-color" "Not a valid color" color))
    (push-buffer! `((type . "lineColor")
                    (color . ,(cdr color-pair))))))

(define (canvas-line-width width)
  (push-buffer! `((type . "lineWidth")
                  (width . ,width))))

(define (canvas-show-turtle x y theta)
  (push-buffer! `((type . "showTurtle")
                  (x . ,x)
                  (y . ,y)
                  (facing . ,theta))))

(define (canvas-hide-turtle)
  (push-buffer! `((type . "hideTurtle"))))