;;; 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))
               (w (pict-width screen))
               (h (pict-height screen)))
          (current-screen
           (lb-superimpose
            (line (* w x1) (- h (* h y1))
                  (* w x2) (- h (* h y2))
                  #:stroke-width (current-line-stroke-width)
                  #:color (current-line-color))))))))))

(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))))