From 486bccd1448c5b55fea52cb6b7b4a3bcc2cc24c4 Mon Sep 17 00:00:00 2001 From: Masaya Tojo Date: Sat, 3 Apr 2021 02:40:03 +0900 Subject: Add (sicp-picture-language) module. * 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. --- sicp-picture-language.scm | 257 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 257 insertions(+) create mode 100644 sicp-picture-language.scm (limited to 'sicp-picture-language.scm') 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 +;;; +;;; 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 +;;; . + +(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 + (%make-vect xcor ycor) + vect? + (xcor xcor-vect) + (ycor ycor-vect)) + +(define-immutable-record-type + (%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 + (($ xcor1 ycor1) + (match vect2 + (($ xcor2 ycor2) + (make-vect (+ xcor1 xcor2) (+ ycor1 ycor2))))))) + +(define/check (sub-vect (vect1 vect?) (vect2 vect?)) + (match-let ((($ xcor1 ycor1) vect1) + (($ xcor2 ycor2) vect2)) + (make-vect (- xcor1 xcor2) (- ycor1 ycor2)))) + +(define/check (scale-vect (scale real?) (vect vect?)) + (match-let ((($ xcor ycor) vect)) + (make-vect (* scale xcor) (* scale ycor)))) + +(define/check (frame-coord-map (frame frame?)) + (match-let ((($ origin edge1 edge2) frame)) + (define/check (frame-coord-map/result (vect vect?)) + (match-let ((($ 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 + (($ x1 y1) + (match end-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 + (($ 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)))) -- cgit v1.2.3