;;; Guile SICP Picture Language --- SICP's picture language for Gulie
;;; Copyright © 2021 Masaya Tojo <masaya@tojo.tokyo>
;;;
;;; This file is part of Guile SICP Picture Language.
;;;
;;; Guile SICP Picture Language is free software; you can redistribute
;;; it and/or modify it under the terms of the GNU General Public
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; Guile SICP Picture Language is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Guile SICP Picture Language. If not, see
;;; <http://www.gnu.org/licenses/>.
(define-module (sicp-picture-language)
#:export (make-vect
vect?
xcor-vect
ycor-vect
add-vect
sub-vect
scale-vect
make-frame
frame?
origin-frame
edge1-frame
edge2-frame
frame-coord-map
painter->pict
pict->painter
draw-line
flip-vert
flip-horiz
rotate180
beside
below)
#:use-module (ice-9 exceptions)
#:use-module (srfi srfi-9 gnu)
#:use-module (ice-9 match)
#:use-module (pict))
(define-immutable-record-type <vect>
(%make-vect xcor ycor)
vect?
(xcor xcor-vect)
(ycor ycor-vect))
(define-immutable-record-type <frame>
(%make-frame origin edge1 edge2)
frame?
(origin origin-frame)
(edge1 edge1-frame)
(edge2 edge2-frame))
(define (option pred)
(lambda (x)
(if x
(pred x)
#t)))
(define-syntax-rule (check name var pred)
(unless (pred var)
(raise-exception
(make-exception
(make-exception-with-origin 'name)
(make-exception-with-message
(format #f "~a: type mismatches (expected: `~a`)" 'var 'pred))
(make-exception-with-irritants var)
(make-programming-error)))))
(define-syntax-rule (define/check (name (var pred) ...) body ...)
(define (name var ...)
(check name var pred)
...
body ...))
(define/check (make-frame (origin vect?) (edge1 vect?) (edge2 vect?))
(%make-frame origin edge1 edge2))
(define/check (make-vect (xcor real?) (ycor real?))
(%make-vect xcor ycor))
(define/check (add-vect (vect1 vect?) (vect2 vect?))
(match vect1
(($ <vect> xcor1 ycor1)
(match vect2
(($ <vect> xcor2 ycor2)
(make-vect (+ xcor1 xcor2) (+ ycor1 ycor2)))))))
(define/check (sub-vect (vect1 vect?) (vect2 vect?))
(match-let ((($ <vect> xcor1 ycor1) vect1)
(($ <vect> xcor2 ycor2) vect2))
(make-vect (- xcor1 xcor2) (- ycor1 ycor2))))
(define/check (scale-vect (scale real?) (vect vect?))
(match-let ((($ <vect> xcor ycor) vect))
(make-vect (* scale xcor) (* scale ycor))))
(define/check (frame-coord-map (frame frame?))
(match-let ((($ <frame> origin edge1 edge2) frame))
(define/check (frame-coord-map/result (vect vect?))
(match-let ((($ <vect> xcor ycor) vect))
(add-vect origin
(add-vect (scale-vect xcor edge1)
(scale-vect ycor edge2)))))
frame-coord-map/result))
(define current-line-color (make-parameter "black"))
(define current-line-stroke-width (make-parameter 1))
(define/check (draw-line (start-vect vect?) (end-vect vect?))
(match start-vect
(($ <vect> x1 y1)
(match end-vect
(($ <vect> x2 y2)
(let ((screen (current-screen)))
(let ((l (line x1 y1
x2 y2
#:stroke-width (current-line-stroke-width)
#:color (current-line-color))))
(current-screen (pin-over screen 0 0 l)))))))))
(define current-screen (make-parameter #f))
(define current-pict-ids (make-parameter '()))
(define (make-screen width height color)
(let ((screen (rectangle width height #:border-width 0)))
(if color
(fill screen color)
screen)))
(define* (painter->pict painter #:key (width 256) (height width) (background-color #f))
(check painter->pict painter procedure?)
(check painter->pict width real?)
(check painter->pict height real?)
(check painter->pict background-color (option string?))
(parameterize ((current-screen (make-screen width height background-color))
(current-pict-ids '()))
(painter (make-frame (make-vect 0 height) (make-vect width 0) (make-vect 0 (- height))))
((@@ (pict) make-pict)
`(svg (@ (height ,height)
(width ,width)
(class "painter")
(x 0)
(y 0)
(xmlns:xlink "http://www.w3.org/1999/xlink"))
(defs
,@(map (match-lambda
((pict . id)
`(symbol (@ (id ,id))
,(pict-sxml pict))))
(current-pict-ids)))
,(pict-sxml (current-screen))))))
(define (pict-transform pict w h a b c d e f)
((@@ (pict) make-pict)
`(svg (@ (height ,(exact->inexact h))
(width ,(exact->inexact w))
(class "matrix")
(x 0)
(y 0))
,(((@@ (pict) transform-modifier) "matrix" (const
(format #f "~a ~a ~a ~a ~a ~a"
a b c d e f)))
`(g (@ (class "transform"))
,((@@ (pict) pict-sxml) pict))))))
(define/check (pict->painter (pict pict?))
(flip-vert
(lambda (frame)
(let ((screen (current-screen)))
(let ((screen-width (pict-width screen))
(screen-height (pict-height screen)))
(let* ((id (cond ((assq-ref (current-pict-ids) pict) => identity)
(else
(let ((id (format #f "pict~a" (length (current-pict-ids)))))
(current-pict-ids (acons pict id (current-pict-ids)))
id))))
(pict ((@@ (pict) make-pict)
`(svg (@ (height ,(pict-height pict))
(width ,(pict-width pict)))
(use (@ (xlink:href ,(format #f "#~a" id))
(href ,(format #f "#~a" id))))))))
(match frame
(($ <frame> origin edge1 edge2)
(current-screen
(lt-superimpose (pict-transform pict
(pict-width screen)
(pict-height screen)
(/ (xcor-vect edge1) (pict-width pict))
(/ (ycor-vect edge1) (pict-height pict))
(/ (xcor-vect edge2) (pict-width pict))
(/ (ycor-vect edge2) (pict-height pict))
(xcor-vect origin)
(ycor-vect origin))
(current-screen)))))))))))
(define (transform-painter painter new-origin new-end-of-edge1 new-end-of-edge2)
(lambda (frame)
(let* ((m (frame-coord-map frame))
(origin (m new-origin)))
(painter (make-frame origin
(sub-vect (m new-end-of-edge1) origin)
(sub-vect (m new-end-of-edge2) origin))))))
(define/check (flip-vert (painter procedure?))
(transform-painter painter
(make-vect 0.0 1.0)
(make-vect 1.0 1.0)
(make-vect 0.0 0.0)))
(define/check (flip-horiz (painter procedure?))
(transform-painter painter
(make-vect 1.0 0.0)
(make-vect 0.0 0.0)
(make-vect 1.0 1.0)))
(define/check (rotate180 (painter procedure?))
(flip-horiz (flip-vert painter)))
(define/check (beside (painter-left procedure?) (painter-right procedure?))
(lambda (frame)
(let ((left (transform-painter painter-left
(make-vect 0.0 0.0)
(make-vect 0.5 0.0)
(make-vect 0.0 1.0)))
(right (transform-painter painter-right
(make-vect 0.5 0.0)
(make-vect 1.0 0.0)
(make-vect 0.5 1.0))))
(left frame)
(right frame))))
(define/check (below (painter-bottom procedure?) (painter-top procedure?))
(lambda (frame)
(let ((bottom (transform-painter painter-bottom
(make-vect 0.0 0.0)
(make-vect 1.0 0.0)
(make-vect 0.0 0.5)))
(top (transform-painter painter-top
(make-vect 0.0 0.5)
(make-vect 1.0 0.5)
(make-vect 0.0 1.0))))
(bottom frame)
(top frame))))
