From b89b720d908acbb7f683f4a8b7815abfc7092ffb Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Sat, 24 Mar 2018 19:51:17 +0100 Subject: Initial commit. --- pict.scm | 703 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 703 insertions(+) create mode 100644 pict.scm 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 +;;; +;;; 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 +;;; . + + +(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 + (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 #. +;; Hey, where are you going? You haven't seen the rest...! +(set-record-type-printer! + (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 "#" 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)) -- cgit v1.2.3