64 lines
2.5 KiB
Common Lisp
64 lines
2.5 KiB
Common Lisp
(in-package #:se.kth.stacken.nya-balken)
|
|
|
|
(defun xmlfloat (number)
|
|
(format nil "~A" (float number)))
|
|
|
|
(defun make-point (x y)
|
|
(format nil " ~D,~D" x y))
|
|
|
|
(defun make-svg (shapes &rest attrs)
|
|
(xmls:write-xml
|
|
(xmls:make-node :name "svg"
|
|
:attrs (append '(("xmlns" "http://www.w3.org/2000/svg"))
|
|
attrs)
|
|
:children shapes)
|
|
nil))
|
|
|
|
(defun make-font-style (name filespec)
|
|
(let (font)
|
|
(with-open-file (stream filespec :element-type '(unsigned-byte 8))
|
|
(let ((font-bytes (make-array (file-length stream) :element-type '(unsigned-byte 8))))
|
|
(read-sequence font-bytes stream)
|
|
(setf font (cl-base64:usb8-array-to-base64-string font-bytes))))
|
|
(xmls:make-node :name "style"
|
|
:child (format nil "@font-face{font-family:\"~A\";src:url(data:application/font-woff;charset=utf-8;base64,~A) format(\"woff2\")}"
|
|
name
|
|
font))))
|
|
|
|
(defparameter *fill-color* "#f00")
|
|
(defparameter *line-color* "none")
|
|
|
|
(defun make-polygon (points &key (color-fill *fill-color*) (color-line *line-color*)
|
|
children)
|
|
(let ((points-string (subseq (apply 'concatenate 'string points) 1)))
|
|
(xmls:make-node :name "polygon" :attrs `(("fill" ,color-fill)
|
|
("stroke" ,color-line)
|
|
("points" ,points-string))
|
|
:children children)))
|
|
|
|
(defun make-rect (x y w h &key (color-fill *fill-color*) (color-line *line-color*)
|
|
children)
|
|
(make-polygon (list
|
|
(make-point x y)
|
|
(make-point (+ x w) y)
|
|
(make-point (+ x w) (+ y h))
|
|
(make-point x (+ y h)))
|
|
:color-fill color-fill :color-line color-line
|
|
:children children))
|
|
|
|
(defun make-trapezoid (x y top-width height bottom-width
|
|
&optional (color-fill *fill-color*) (color-line *line-color*))
|
|
(let* ((bottom-offset (/ (- top-width bottom-width) 2)))
|
|
(make-polygon (list
|
|
(make-point x y)
|
|
(make-point (+ x top-width) y)
|
|
(make-point (+ x bottom-width bottom-offset)
|
|
(+ y height))
|
|
(make-point (+ x bottom-offset)
|
|
(+ y height)))
|
|
:color-fill color-fill :color-line color-line)))
|
|
|
|
(defvar *shapes* '())
|
|
|
|
(defun add (shape)
|
|
(push shape *shapes*))
|