aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMasaya Tojo <masaya@tojo.tokyo>2021-04-03 02:40:03 +0900
committerMasaya Tojo <masaya@tojo.tokyo>2021-04-05 05:11:30 +0900
commit486bccd1448c5b55fea52cb6b7b4a3bcc2cc24c4 (patch)
tree3d1afc148e1f65664019be6ae7bc58b2c6c9c9d1
parent30a87b89d66252058d4751e2820316d033311fbf (diff)
Add (sicp-picture-language) module.v0.2.0
* sicp-picture-language.scm: New file. * configure.ac (AC_INIT): Version up `0.1.0` to `0.2.0`. * configure.ac (AC_CONFIG_SRCDIR): Set `sicp-picture-language.scm` file. * guix.scm (version): Version up `0.1.0` to `0.2.0`. * Makefile.am (SOURCE): Add `sicp-picture-language` file.
-rw-r--r--Makefile.am3
-rw-r--r--configure.ac4
-rw-r--r--guix.scm2
-rw-r--r--sicp-picture-language.scm257
4 files changed, 262 insertions, 4 deletions
diff --git a/Makefile.am b/Makefile.am
index c917786..70d2464 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -42,7 +42,8 @@ godir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache
bin_SCRIPTS =
-SOURCES =
+SOURCES = \
+ sicp-picture-language.scm
TESTS =
diff --git a/configure.ac b/configure.ac
index 89883e8..a8e6dc1 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1,5 +1,5 @@
-AC_INIT([guile-sicp-picture-language], [0.1.0])
-AC_CONFIG_SRCDIR([<srcfile>])
+AC_INIT([guile-sicp-picture-language], [0.2.0])
+AC_CONFIG_SRCDIR([sicp-picture-language.scm])
AC_CONFIG_AUX_DIR([build-aux])
AM_INIT_AUTOMAKE([-Wall -Werror foreign])
AM_SILENT_RULES([yes])
diff --git a/guix.scm b/guix.scm
index 675a206..73a8fe5 100644
--- a/guix.scm
+++ b/guix.scm
@@ -31,7 +31,7 @@
(define guile-sicp-picture-language
(package
(name "guile-sicp-picture-language")
- (version "0.1.0")
+ (version "0.2.0")
(source (string-append (getcwd) "/guile-sicp-picture-language-" version ".tar.gz"))
(build-system gnu-build-system)
(native-inputs
diff --git a/sicp-picture-language.scm b/sicp-picture-language.scm
new file mode 100644
index 0000000..39f9c8e
--- /dev/null
+++ b/sicp-picture-language.scm
@@ -0,0 +1,257 @@
+;;; 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))))