;;;; SPDX-FileCopyrightText: 2014 Peter Danenberg ;;;; SPDX-FileCopyrightText: 2021 Vasilij Schneidermann ;;;; ;;;; SPDX-License-Identifier: BSD-3-Clause (define canvas-width (make-parameter 256)) (define canvas-height (make-parameter 256)) (define canvas-path (make-parameter #f)) (define canvas-stack (make-parameter '())) (define (canvas-frame) `((0 0) (,(canvas-width) 0) (0 ,(canvas-height)))) (define (display-svg svg out) (define (entity-encode string) (string-translate* string '(("<" . "<") (">" . ">") ("&" . "&") ("'" . "'") ("\"" . """)))) (cond ((string? svg) (entity-encode svg)) ;; (foo (@ ...) body ...) ((and (pair? svg) (symbol? (car svg)) (pair? (cdr svg)) (pair? (cadr svg))) (let ((tag (car svg)) (attrs (cdr (cadr svg))) (body (cddr svg))) (fprintf out "<~a" tag) (for-each (lambda (attr) (fprintf out " ~a=~s" (car attr) (cadr attr))) attrs) (if (pair? body) (begin (display ">" out) (for-each (lambda (form) (display-svg form out)) body) (fprintf out "" tag)) (display "/>" out)))) (else (error "Malformed SXML")))) (define (canvas-svg) `(svg (@ (xmlns "http://www.w3.org/2000/svg") (xmlns:xlink "http://www.w3.org/1999/xlink") (height ,(number->string (canvas-height))) (width ,(number->string (canvas-width)))) (g (@ (stroke "black")) ,@(reverse (canvas-stack))))) (define (canvas-ensure) (when (not (canvas-path)) (canvas-path (create-temporary-file ".svg")))) (define (canvas-cleanup) (when (canvas-path) (delete-file* (canvas-path)) (canvas-path #f))) (define (canvas-reset) (canvas-stack '())) (define (canvas-refresh) (canvas-ensure) (call-with-output-file (canvas-path) (lambda (out) (display-svg (canvas-svg) out))) (string-append "file://" (canvas-path))) (define origin-frame car) (define edge1-frame cadr) (define edge2-frame caddr) (define xcor-vect car) (define ycor-vect cadr) (define (draw-line start end) (define svg ;; convert y coordinates to SVG convention `(line (@ (x1 ,(number->string (xcor-vect start))) (y1 ,(number->string (- (canvas-height) (ycor-vect start)))) (x2 ,(number->string (xcor-vect end))) (y2 ,(number->string (- (canvas-height) (ycor-vect end))))))) (canvas-stack (cons svg (canvas-stack)))) (define (draw-image uri frame) (define svg ;; convert from cartesian, bottom left origin, to SVG, top left origin style coordinates. (let* ((origin (origin-frame frame)) (edge1 (edge1-frame frame)) (edge2 (edge2-frame frame)) ;; svg-origin is upper left-hand corner - add edge2 to origin (svg-origin-x (+ (xcor-vect origin) (xcor-vect edge2))) (svg-origin-y (- (canvas-height) ; convert to svg coords (+ (ycor-vect origin) (ycor-vect edge2)))) ;; svg-edge1 (svg-edge1-x (xcor-vect edge1)) ;; up is down (svg-edge1-y (- (ycor-vect edge1))) ;; svg edge 2 inverse of edge2 (svg-edge2-x (- (xcor-vect edge2))) ;; don't need to invert y as up is down (svg-edge2-y (ycor-vect edge2))) `(g (@ (transform ,(format "matrix(~a, ~a, ~a, ~a, ~a, ~a)" svg-edge1-x svg-edge1-y svg-edge2-x svg-edge2-y svg-origin-x svg-origin-y))) (image (@ (xlink:href ,uri) (width "1") (height "1")))))) (canvas-stack (cons svg (canvas-stack)))) (define (rogers frame) (draw-image rogers-data-url frame)) (define (image-file->painter file-name) (lambda (frame) (draw-image file-name frame))) (define (jpeg-file->painter file-name) (image-file->painter file-name))