Initial commit.

1 files changed, 703 insertions, 0 deletions

diff --git a/pict.scm b/pict.scm
new file mode 100644
index 0000000..6c7bef6
--- /dev/null
+++ b/pict.scm
@@ -0,0 +1,703 @@
+;;; pict.scm --- A simple picture language for Guile
+
+;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;;
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 3 of
+;;; the License, or (at your option) any later version.
+;;; 
+;;; This library 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
+;;; Lesser General Public License for more details.
+;;; 
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+
+(define-module (pict)
+  #:use-module (sxml simple)
+  #:use-module (sxml transform)
+  #:use-module (sxml fold)
+  #:use-module ((sxml xpath) #:hide (filter))
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match)
+  #:export (pict?
+            pict-sxml
+            pict-width
+            pict-height
+
+            ;; modifiers
+            fill
+            colorize
+            remove-outline
+            scale
+            expand
+            grow
+            shrink
+            rotate
+            blur
+
+            frame
+
+            ;; graphics primitives
+            line
+            polyline
+            polygon
+            circle
+            ellipse
+            rectangle
+
+            ;; other graphics
+            disk
+            filled-ellipse
+            filled-rectangle
+            triangle
+            filled-triangle
+            octagon
+            filled-octagon
+
+            text
+
+            ;; composition
+            vl-append
+            vc-append
+            vr-append
+
+            ht-append
+            hc-append
+            hb-append
+
+            lt-superimpose
+            lc-superimpose
+            lb-superimpose
+
+            ct-superimpose
+            cc-superimpose
+            cb-superimpose
+
+            rt-superimpose
+            rc-superimpose
+            rb-superimpose))
+
+
+;;; Records
+
+;; This is the main record for pictures, a simple wrapper around SXML.
+;; We only use a record so that we can abuse the record type printer
+;; facility (see below).  All operations are really performed on the
+;; wrapped SXML.
+(define-record-type <pict>
+  (make-pict sxml)
+  pict?
+  (sxml pict-sxml))
+
+;; XXX: This is a hack to let Geiser display the image.
+;; Since Geiser only supports the display of images that are
+;; associated with a file we write out the SVG to a temp file and
+;; return #<Image: /path/to/svg>.
+;; Hey, where are you going?  You haven't seen the rest...!
+(set-record-type-printer! <pict>
+ (lambda (record port)
+   (let* ((xml  (with-output-to-string
+                  (lambda _ (sxml->xml `(svg (@ (width ,(pict-width record))
+                                                (height ,(pict-height record)))
+                                             ,(pict-sxml record))))))
+          (name (string-append "/tmp/geiser-"
+                               (number->string (string-hash xml))
+                               ".svg")))
+     (with-output-to-file name
+       (lambda _ (display xml)))
+     (format port "#<Image: ~a>" name))))
+
+
+;;; Miscellaneous utilities
+
+(define (scan vals)
+  "Return a list of cumulative offsets for each numeric value in the
+list VALS."
+  (reverse
+   (fold (lambda (val acc)
+           (match acc
+             ((last . lst)
+              (let ((offset (+ val last)))
+                (cons offset (cons offset lst))))))
+         '(0 . ())
+         (cons 0 vals))))
+
+
+;;; SXML utilities
+
+(define (modify-attribute search-key proc node)
+  "Find an attribute with the key SEARCH-KEY in the attributes of
+NODE.  Run PROC on the current value of the found attribute or create
+the attribute by running PROC on #F."
+  (let ((attributes (cdr node)))
+    (cons '@
+     (match (fold (lambda (attribute state)
+                    (match attribute
+                      ((key vals)
+                       (if (eq? key search-key)
+                           (cons #t     ; replaced!
+                                 (cons (list key (proc vals))
+                                       (cdr state)))
+                           (cons (car state)
+                                 (cons attribute (cdr state)))))))
+                  '(#f . ())
+                  attributes)
+       ((#f . attrs)
+        (cons (list search-key (proc #f))
+              attrs))
+       ((_ . attrs) attrs)))))
+
+(define (attribute-modifier attribute proc)
+  "Return a procedure that takes an SXML element and modifies or adds
+ATTRIBUTE by applying PROC to the current value (or #F)."
+  (match-lambda
+    ((tag attrs . inner)
+     `(,tag ,(modify-attribute attribute proc attrs)
+            ,@inner))))
+
+(define (transform-string->list ts)
+  "Split the transform string TS into a list of lists from keys to
+values."
+  (map (compose (cut take <> 2)
+                (cut string-split <> #\()
+                (cut string-trim-both <>))
+       (filter (negate string-null?) (string-split ts #\)))))
+
+(define (transform-list->string lst)
+  "Returns an SVG string of transforms that are built from the list
+of transform lists LST."
+  (string-join (map (match-lambda
+                      ((key val)
+                       (string-append key "(" val ")")))
+                    lst)))
+
+(define (transform-modifier key value)
+  (attribute-modifier
+   'transform
+   (lambda (transform-str)
+     (transform-list->string
+      (cons (list key value)
+            (filter (match-lambda
+                      ((k _)
+                       (not (string=? k key)))
+                      (_ '()))
+                    (transform-string->list (or transform-str ""))))))))
+
+(define (style-string->list styles)
+  "Split the styles string into a list of lists from keys to values."
+  (map (cut string-split <> #\:)
+       (string-split styles #\;)))
+
+(define (style-list->string lst)
+  "Returns a string of semicolon-separated pairs of colon-separated
+strings that are built from the list of attributes LST."
+  (string-join (map (cut string-join <> ":") lst) ";"))
+
+(define (style-modifier key value)
+  (attribute-modifier
+   'style
+   (lambda (style-str)
+     (style-list->string
+      (cons (list key value)
+            (filter (match-lambda
+                      ((k _)
+                       (not (string=? k key)))
+                      (_ '()))
+                    (style-string->list (or style-str ""))))))))
+
+(define (update-style key value sxml)
+  ((style-modifier key value) sxml))
+
+
+;;; Picture modifiers
+
+;; Picts are wrapped in an SVG tag to allow us to record the width and
+;; height (and any transformations).  Graphic primitives may be buried
+;; deep inside wrapping SVG elements after composition and
+;; transformations, so we use foldt to apply modifications to the
+;; inner graphic primitives.
+(define (pict-modify-primitives pict proc)
+  "Apply PROC to all graphic primitives in PICT."
+  (make-pict
+   (foldt (lambda (thing)
+            (let ((tag (car thing)))
+              (if (member tag '(rect polygon polyline circle ellipse text))
+                  (proc thing) thing)))
+          identity
+          (pict-sxml pict))))
+
+(define (fill pict color)
+  "Fill PICT with COLOR."
+  (pict-modify-primitives pict
+                          (lambda (inner)
+                            (update-style "fill" color inner))))
+
+(define (colorize pict color)
+  "Set the outer COLOR of PICT."
+  (pict-modify-primitives pict
+                          (lambda (inner)
+                            (update-style "stroke" color inner))))
+
+(define remove-outline (cut colorize <> "none"))
+
+(define pi (/ 355 113))
+(define (deg->rad deg)
+  (* deg (/ pi 180)))
+
+;; Nested SVGs lose their transforms!  So we need to use "g" and SVG
+;; for wrapping.  "g" for the transform and SVG for x, y, width, and
+;; height (because "g" doesn't have those).
+
+;; XXX: repeated rotations result in an increase of the size of the
+;; pict, as they are not applied to the inner shape but wrapped around
+;; the pict.  It may be better to get at the inner shape first by
+;; finding the child of the first (g (@ (class "transform")) ...)
+;; expression.
+(define (rotate pict deg)
+  "Rotate the PICT by DEG degrees."
+  (let* ((width  (pict-width pict))
+         (height (pict-height pict))
+         (cx     (/ width 2))
+         (cy     (/ height 2))
+         (vecx   (make-rectangular width 0))
+         (vecy   (make-rectangular 0 height))
+         (rot    (make-polar 1 (deg->rad deg)))
+         (rotx   (* vecx rot))
+         (roty   (* vecy rot))
+         (new-height (+ (abs (imag-part rotx))
+                        (abs (imag-part roty))))
+         (new-width  (+ (abs (real-part rotx))
+                        (abs (real-part roty)))))
+    (make-pict
+     `(svg (@ (height ,new-height)
+              (width ,new-width)
+              (class "rotate")
+              (x 0)
+              (y 0))
+           ,((compose (transform-modifier "translate"
+                                          (format #f "~a ~a"
+                                                  (/ (- new-width width) 2)
+                                                  (/ (- new-height height) 2)))
+                      (transform-modifier "rotate"
+                                          (format #f "~a ~a ~a"
+                                                  deg cx cy)))
+             `(g (@ (class "transform")) ,(pict-sxml pict)))))))
+
+(define (scale pict factor)
+  "Scale the PICT by the given FACTOR."
+  (make-pict
+   `(svg (@ (height ,(* factor (pict-height pict)))
+            (width ,(* factor (pict-width pict)))
+            (class "scale")
+            (x 0)
+            (y 0))
+         ,((transform-modifier "scale" (number->string factor))
+           `(g (@ (class "transform"))
+               ,(pict-sxml pict))))))
+
+(define* (expand pict
+                 #:key
+                 (amount 0)
+                 (left amount) (right amount)
+                 (top amount) (bottom amount))
+  "Expand the bounding box of PICT."
+  (let ((w (pict-width pict))
+        (h (pict-height pict)))
+    (make-pict
+     `(svg (@ (width ,(+ w left right))
+              (height ,(+ h top bottom)))
+           ,((compose (attribute-modifier 'x (lambda (x) (+ left x)))
+                      (attribute-modifier 'y (lambda (y) (+ top y))))
+             (pict-sxml pict))))))
+
+(define (grow pict amount)
+  "Grow the bounding box of PICT."
+  (expand pict #:amount amount))
+
+(define (shrink pict amount)
+  "Shrink the bounding box of PICT."
+  (expand pict #:amount (- amount)))
+
+;;; XXX: Emacs doesn't render filters when the image type is SVG.  It
+;;; only does this when the image type is 'imagemagick, i.e. when the
+;;; SVG is first fed to ImageMagick and the raster image is displayed.
+(define (blur pict radius)
+  "Apply a Gaussian blur with blur RADIUS to the PICT."
+  (let ((new-height (+ (pict-height pict) (* 2 radius)))
+        (new-width (+ (pict-width pict) (* 2 radius))))
+    (make-pict
+     `(svg (@ (width ,new-width)
+              (height ,new-width)
+              (class "blur"))
+           (g (defs
+                (filter
+                 (@ (id "blur")
+                    (width ,new-width)
+                    (height ,new-height))
+                 (feGaussianBlur
+                  (@ (stdDeviation ,(number->string radius)))))))
+           ,((compose (style-modifier "filter" "url(#blur)")
+                      (attribute-modifier 'x (const (/ (- new-width
+                                                          (pict-width pict))
+                                                       2)))
+                      (attribute-modifier 'y (const (/ (- new-height
+                                                          (pict-height pict))
+                                                       2))))
+             (pict-sxml pict))))))
+
+(define* (frame pict #:key (color "black") (stroke-width 1))
+  "Draw a box around PICT."
+  (cc-superimpose pict
+                  (rectangle (pict-width pict)
+                             (pict-height pict)
+                             #:border-color color
+                             #:border-width stroke-width)))
+
+
+;;; SVG graphics primitives.
+
+;;; Each shape is wrapped in an SVG tag that records the width,
+;;; height, and the coordinates.
+
+(define* (line x1 y1 x2 y2
+               #:key
+               (color "black")
+               (stroke-width 1))
+  (make-pict
+   `(svg (@ (width ,(let ((new-width (+ (min x1 x2)
+                                        (abs (- x2 x1)))))
+                      (if (zero? new-width)
+                          stroke-width new-width)))
+            (height ,(let ((new-height (+ (min y1 y2)
+                                          (abs (- y2 y1)))))
+                       (if (zero? new-height)
+                           stroke-width new-height)))
+            (x 0)
+            (y 0))
+         (line (@ (x1 ,x1)
+                  (y1 ,y1)
+                  (x2 ,x2)
+                  (y2 ,y2)
+                  (style ,(style-list->string
+                           `(("stroke" ,color)
+                             ("stroke-width"
+                              ,(number->string stroke-width))))))))))
+
+(define* (polyline points
+               #:key
+               (color "black")
+               (stroke-width 1))
+  "Draw a polyline from POINTS, a list of x and y coordinate pairs."
+  (let* ((xs (map car points))
+         (ys (map cdr points)))
+    (make-pict
+     `(svg (@ (width ,(+ (apply min xs)
+                         (apply max xs)))
+              (height ,(+ (apply min ys)
+                          (apply max ys)))
+              (x 0)
+              (y 0))
+           (polyline (@ (points ,(string-join
+                                  (map (match-lambda
+                                         ((x . y)
+                                          (string-append (number->string x)
+                                                         ","
+                                                         (number->string y))))
+                                       points)))
+                        (style ,(style-list->string
+                                 `(("fill" "none")
+                                   ("stroke" ,color)
+                                   ("stroke-width"
+                                    ,(number->string stroke-width)))))))))))
+
+(define* (polygon points
+               #:key
+               (border-color "black")
+               (border-width 1))
+  "Draw a polygon from POINTS, a list of x and y coordinate pairs."
+  (let* ((xs (map car points))
+         (ys (map cdr points)))
+    (make-pict
+     `(svg (@ (width ,(+ (apply min xs)
+                         (apply max xs)))
+              (height ,(+ (apply min ys)
+                          (apply max ys)))
+              (x 0)
+              (y 0))
+           (polygon (@ (points ,(string-join
+                                 (map (match-lambda
+                                        ((x . y)
+                                         (string-append (number->string x)
+                                                        ","
+                                                        (number->string y))))
+                                      points)))
+                       (style ,(style-list->string
+                                `(("fill" "none")
+                                  ("stroke" ,border-color)
+                                  ("stroke-width"
+                                   ,(number->string border-width)))))))))))
+
+;; An isosceles triangle
+(define* (triangle w h
+                   #:key
+                   (border-color "black")
+                   (border-width 1))
+  (polygon `((0 . ,h)
+             (,w . ,h)
+             (,(/ w 2) . 0))
+           #:border-color border-color
+           #:border-width border-width))
+
+(define* (filled-triangle w h #:key (color "black"))
+  (remove-outline (fill (triangle w h) color)))
+
+;; A boring p8 symmetric isogonal octagon
+(define* (octagon size
+                  #:key
+                  (border-color "black")
+                  (border-width 1))
+  (let ((third (exact->inexact (/ size 3))))
+    (polygon `((0 . ,(* 2 third))
+               (0 . ,third)
+               (,third . 0)
+               (,(* 2 third) . 0)
+               (,size . ,third)
+               (,size . ,(* 2 third))
+               (,(* 2 third) . ,size)
+               (,third . ,size))
+             #:border-color border-color
+             #:border-width border-width)))
+
+(define* (filled-octagon size #:key (color "black"))
+  (remove-outline (fill (octagon size) color)))
+
+(define* (circle radius
+                 #:key
+                 (border-color "black")
+                 (border-width 1))
+  (make-pict
+   `(svg (@ (width ,(* 2 radius))
+            (height ,(* 2 radius))
+            (x 0)
+            (y 0))
+         (circle (@ (style ,(style-list->string
+                             `(("fill" "none")
+                               ("stroke" ,border-color)
+                               ("stroke-width"
+                                ,(number->string border-width)))))
+                    (cx ,radius)
+                    (cy ,radius)
+                    (r  ,radius))))))
+
+(define* (disk radius
+               #:key
+               (color "black"))
+  (remove-outline (fill (circle radius) color)))
+
+(define* (ellipse w h
+                  #:key
+                  (border-color "black")
+                  (border-width 1))
+  (make-pict
+   `(svg (@ (width ,w)
+            (height ,h)
+            (x 0)
+            (y 0))
+         (ellipse (@ (style ,(style-list->string
+                              `(("fill" "none")
+                                ("stroke" ,border-color)
+                                ("stroke-width"
+                                 ,(number->string border-width)))))
+                     (cx ,(/ w 2))
+                     (cy ,(/ h 2))
+                     (rx ,(/ w 2))
+                     (ry ,(/ h 2)))))))
+
+(define* (filled-ellipse w h #:key (color "black"))
+  (remove-outline (fill (ellipse w h) color)))
+
+(define* (rectangle w h
+                    #:key
+                    (border-color "black")
+                    (border-width 1)
+                    (rx 0)
+                    (ry 0))
+  (make-pict
+   `(svg (@ (width ,w)
+            (height ,h)
+            (x 0)
+            (y 0))
+         (rect (@ (style ,(style-list->string
+                           `(("fill" "none")
+                             ("stroke" ,border-color)
+                             ("stroke-width"
+                              ,(number->string border-width)))))
+                  (x 0)
+                  (y 0)
+                  (width ,w)
+                  (height ,h)
+                  (rx ,rx)
+                  (ry ,ry))))))
+
+(define* (filled-rectangle w h #:key
+                           (color "black")
+                           (border-color "none")
+                           (border-width 1)
+                           (rx 0)
+                           (ry 0))
+  (fill (rectangle w h
+                   #:border-color border-color
+                   #:border-width border-width
+                   #:rx rx
+                   #:ry ry) color))
+
+;; XXX: We need to ask the user to provide width and height, because
+;; we cannot determine these dimensions without rendering the text.
+;; Even so, the text is cut off in some cases when letters go below
+;; the baseline.  This needs more work.
+(define* (text txt w h
+               #:key
+               (color "black"))
+  (make-pict
+   `(svg (@ (width ,w)
+            (height ,h)
+            (x 0)
+            (y 0))
+         (text (@ (style ,(style-list->string
+                           `(("fill" ,color)
+                             ("font-family" "sans-serif")
+                             ("font-size" ,(number->string h))
+                             ("text-anchor" "middle"))))
+                  (x ,(/ w 2)) (y ,h))
+               ,txt))))
+
+
+(define (pict-attr attr pict)
+  "Return the value of the selected ATTRIBUTE of the outermost element
+of the SVG of PICT."
+  (and=> ((sxpath `(@ ,attr *any*))
+          (pict-sxml pict))
+         car))
+
+(define (pict-height pict)
+  "Return the height of PICT."
+  (pict-attr 'height pict))
+
+(define (pict-width pict)
+  "Return the width of PICT."
+  (pict-attr 'width pict))
+
+(define (append-align xalign yalign picts)
+  "Append PICTS and align them vertically to the top, center, bottom,
+or spread by an offset according to the symbol YALIGN and horizontally
+to the left, center, right, or spread them with an offset according to
+the symbol XALIGN."
+  (let* ((heights    (map pict-height picts))
+         (widths     (map pict-width picts))
+         (new-height (apply (if (eq? yalign 'offset) + max) heights))
+         (new-width  (apply (if (eq? xalign 'offset) + max) widths))
+         (x-offsets  (if (eq? xalign 'offset)
+                         (scan widths)
+                         (list-tabulate (length picts) (const 0))))
+         (y-offsets  (if (eq? yalign 'offset)
+                         (scan heights)
+                         (list-tabulate (length picts) (const 0))))
+         (aligner    (match-lambda
+                       ((xoffset yoffset pict)
+                        ((compose
+                          (attribute-modifier
+                           'x (match xalign
+                                ('left   identity)
+                                ('center (lambda _
+                                           (- (/ new-width 2)
+                                              (/ (pict-width pict) 2))))
+                                ('right  (lambda _
+                                           (- new-width
+                                              (pict-width pict))))
+                                ('offset (const xoffset))))
+                          (attribute-modifier
+                           'y (match yalign
+                                ('top    identity)
+                                ('center (lambda _
+                                           (- (/ new-height 2)
+                                              (/ (pict-height pict) 2))))
+                                ('bottom (lambda _
+                                           (- new-height
+                                              (pict-height pict))))
+                                ('offset (const yoffset)))))
+                         (pict-sxml pict))))))
+    (make-pict
+     `(svg (@ (height ,new-height)
+              (width  ,new-width)
+              (class ,(string-append "aligned-"
+                                     (symbol->string xalign)
+                                     "-"
+                                     (symbol->string yalign)))
+              (x 0)
+              (y 0))
+           ,@(map aligner (zip x-offsets y-offsets picts))))))
+
+(define (ht-append . picts)
+  "Line up the given PICTS horizontally on the top."
+  (append-align 'offset 'top picts))
+
+(define (hc-append . picts)
+  "Line up the given PICTS horizontally and center them."
+  (append-align 'offset 'center picts))
+
+(define (hb-append . picts)
+  "Line up the given PICTS horizontally on the top."
+  (append-align 'offset 'bottom picts))
+
+(define (vl-append . picts)
+  "Line up the given PICTS vertically and left-align them."
+  (append-align 'left 'offset picts))
+
+(define (vc-append . picts)
+  "Line up the given PICTS vertically and center them."
+  (append-align 'center 'offset picts))
+
+(define (vr-append . picts)
+  "Line up the given PICTS vertically and right-align them."
+  (append-align 'right 'offset picts))
+
+(define (lt-superimpose . picts)
+  "Stack the given PICTS and align them left and at the top."
+  (append-align 'left 'top picts))
+(define (lc-superimpose . picts)
+  "Stack the given PICTS and align them left and center them
+vertically."
+  (append-align 'left 'center picts))
+(define (lb-superimpose . picts)
+  "Stack the given PICTS and align them left and at the bottom."
+  (append-align 'left 'bottom picts))
+
+(define (ct-superimpose . picts)
+  "Stack the given PICTS and center them horizontally and align at the
+top."
+  (append-align 'center 'top picts))
+(define (cc-superimpose . picts)
+  "Stack the given PICTS and center them horizontally and vertically."
+  (append-align 'center 'center picts))
+(define (cb-superimpose . picts)
+  "Stack the given PICTS and center them horizontally and align at the
+bottom."
+  (append-align 'center 'bottom picts))
+
+(define (rt-superimpose . picts)
+  "Stack the given PICTS and align them right and at the top."
+  (append-align 'right 'top picts))
+(define (rc-superimpose . picts)
+  "Stack the given PICTS and align them right and center them vertically."
+  (append-align 'right 'center picts))
+(define (rb-superimpose . picts)
+  "Stack the given PICTS and align them right and at the bottom."
+  (append-align 'right 'bottom picts))