Initial commit

Makefile

@@ -0,0 +1,8 @@
+LISP = sbcl
+LISPFLAGS = --noinform --disable-debugger
+
+stacken.svg: stacken.woff2 nya-balken.asd package.lisp svg-tools.lisp balken.lisp
+	sbcl $(LISPFLAGS) --load "nya-balken.asd" \
+         --eval "(setf *compile-verbose* nil)" \
+         --eval "(asdf:load-system '#:nya-balken :verbose nil)" \
+         --eval "(se.kth.stacken.nya-balken:main)" --eval "(sb-ext:exit)" > $@

balken.lisp

@@ -0,0 +1,77 @@
+(in-package #:se.kth.stacken.nya-balken)
+
+;;; Parameters
+(defparameter edge-width 26)
+(defparameter edge-height 1)
+
+(defparameter background-width 24)
+(defparameter background-height 8)
+
+(defparameter slope-height 1)
+(defparameter slope-x-offset (/ (- edge-width background-width) 2))
+
+(defparameter font-size 6)
+(defparameter text-width 20.4)
+
+(defparameter edge-color "#ad0000")
+(defparameter background-color "#ad0000")
+(defparameter slope-color "#860000")
+
+(defun make-stacken-text ()
+  (labels ((make-span (text spacing)
+             (xmls:make-node :name "tspan" :attrs `(("style" ,(format nil "letter-spacing:~A" spacing)))
+                             :child text)))
+    (let ((subspans (list (make-span "S" "-0.01em")
+                          (make-span "t" "-0.05em")
+                          (make-span "a" "-0.05em")
+                          (make-span "cken" 0))))
+      (xmls:make-node :name "tspan"
+                      :attrs `(("style" ,(format nil "font:~Dpx rtxbsc;fill:white;text-anchor: middle"
+                                                 font-size)))
+                      :children subspans))))
+
+(defun make-beam ()
+  (let ((*shapes* nil))
+    ;; Font
+    (add (make-font-style "rtxbsc" "stacken.woff2"))
+    (let ((*fill-color* edge-color))
+      ;; Edges
+      (add (make-rect 0 0 edge-width edge-height))
+      (add (make-rect 0 (+ edge-height (* slope-height 2) background-height)
+                      edge-width edge-height)))
+    ;; Background and text
+    (let ((*fill-color* background-color))
+      (add (make-rect slope-x-offset (+ edge-height slope-height)
+                      background-width background-height)))
+    (add (xmls:make-node :name "text"
+                         :attrs `(("x" ,(xmlfloat (/ edge-width 2)))
+                                  ("y" ,(xmlfloat
+                                         (+ edge-height slope-height
+                                            (/ font-size 1.375) (/ background-height 4))))
+                                  ;;("class" "stacken-wordmark")
+                                  )
+                         :child (make-stacken-text)))
+    ;; Slopes
+    (let ((*fill-color* slope-color))
+      (add (make-trapezoid 0 edge-height edge-width slope-height
+                           background-width))
+      (add (make-trapezoid slope-x-offset (+ edge-height slope-height background-height)
+                           background-width slope-height
+                           edge-width)))
+    ;; Finalize
+    (make-svg (nreverse *shapes*)
+              `("viewbox"
+                ,(format nil "~D ~D ~D ~D"
+                         0 0
+                         edge-width
+                         (+ (* edge-height 2)
+                            background-height
+                            (* slope-height 2))))
+              `("width" ,edge-width)
+              `("height" ,(+ (* edge-height 2)
+                             background-height
+                             (* slope-height 2))))))
+
+(defun main ()
+  ;;(with-open-file (out "test.svg" :direction :output :if-exists :supersede))
+  (write-string (make-beam)))

nya-balken.asd

@@ -0,0 +1,12 @@
+(in-package #:asdf-user)
+
+(defsystem #:nya-balken
+  :version "0.1.0"
+  :author "John Lorentzson <duuqnd@stacken.kth.se>"
+  :depends-on (#:xmls #:cl-base64)
+  :build-operation "asdf:program-op"
+  :build-pathname "nya-balken"
+  :entry-point "se.kth.stacken.nya-balken:main"
+  :components ((:file "package")
+               (:file "svg-tools")
+               (:file "balken")))

package.lisp

@@ -0,0 +1,5 @@
+(in-package #:cl-user)
+
+(defpackage #:se.kth.stacken.nya-balken
+  (:use #:cl)
+  (:export #:main #:make-beam))

stacken.svg

@@ -0,0 +1 @@
+<svg xmlns="http://www.w3.org/2000/svg" viewbox="0 0 26 12" width="26" height="12"><style>@font-face{font-family:&quot;rtxbsc&quot;;src:url(data:application/font-woff;charset=utf-8;base64,d09GMgABAAAAAASYAA0AAAAACOAAAARBAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP0ZGVE0cGh4GVgCCZBEICoZIhSMLFgABNgIkAygEIAWDSAc2Gz4HAB6FccNdWltiiKNgMnj64+GftX73zezOFzGgEQrNLalHD4VDwxtNxJuZhCK+P4+nvWTOn/gzZCS7DmB653ZQ1/kAseb/5/9yh9vvA92YaPf8hJbNFR0WlS1aRgn2orH8sNO2QZoFJAFIiFm7klLyYNcsO/jorq57KgR82PCfBXxMrF4KwMekTgYIlKMRSIRUiZBDgogr8V2eZCW5H8Dq2hdv2QdJ4bMUVKD+uPnBhQBmaUiZgpuMuEsOAUhpq90KmH6GQDtxA4BixRLMU6WhELOUqy+EghChWDW2N8whLwNFREYAIkFCKCz8dqRy8iCjCIpLhE+IQgkoBfVAMdEGYhAAyAEgEemxuqV6Pb10vbXkqDilISJ4DtR17ApjAYLS2LWOFk1qZKL0LWtMU1KSOIevU/ybBO8WEiQLkYBGUHr0JsUH1n7NGSRI5STJ0pxVbPnEylETQk7p49sUfwRg1SFDBKVbD7oAuwIJbqXKUbFKQyASiQgeTlEFdlxNIBSqARWnVhFUyHHVHE7YsK1wdKVx9cXrSclC4+Ltq4EsnU+ya5yd4HVH7l1JEWWTCN5aFwLNYa9TfJedFF+zDWy5gQSrJidFw10eNy0O6o6CfNGmc9E33qFfKdJAULrxJsXfDewad+GZFXvWTBdTM0ddRk3ov+Fxo91JVKrcqReY48+RVT3Dx36K8gvixcnWNTjQfo7KXJP+Oq0BTlt33uUe9wHnATiZviTJyaO6k88tndVTZBRKHxeXP41XaTlHJ9jVX8tbLNeqFheaBKtG6BEeJlfs1gpWyA8ZVMSdg1pU0Ntg7VfKIuvdZfg9Hbn38oyKl65rgi0dDP+fY+nNiOUZiEl+WDy8d5by4W/k4EAcfo5Vslk0/Kc3mHfGeM7shftCnaQlBzUO4BOYDHZKyTz6p52Fi9tVxLTWa2lywGBBIp7CKnHaXpUxiF5/R/0Qk5GAhZCwwjUuPdGYjiCo8fRm7Q3e8S6q95800hI6/wLiTXfbl2IlldUXH1jpv6XEiidaa0/SG72j7HCONm5vGOnpmKH/wTZv7ZyU5iX22Ub5s/BnXBdnnL0tq1k6TJsY6AGAQMr9z4kGuQpe36RR+vWqqiNZEP/jLlAsAUE8LzDZY078FYRdOloRoxt4RXKQid2AklCP5SgWgkbsDhEejeqNBAlCoB8AVDoIBKCGERZCZhCSEJOEVA8rhZzMEyGv3M/tmSzqiIlcCXqAIIRyvZCEGCmkBskTcspdE/KaPWwuUx5543HVqVeqWhWGIxt28llhhIoTBV5RT+toY5dvxYTGRQEs0aBFgXocsGRZS0E9B2A0rkKlGlWCP8u1AIZwWw390TrFuBgO65AMj3E209rrwIE1Zw0c2JXO4JtdaEldMZdxsLFjPJhVNdBxcLB2tn64m2Fbs51w/Fyz+EcJoVrYwUG7FDFz8SAhwsSIlyIVAAAA) format(&quot;woff2&quot;)}</style><polygon fill="#ad0000" stroke="none" points="0,0 26,0 26,1 0,1"/><polygon fill="#ad0000" stroke="none" points="0,11 26,11 26,12 0,12"/><polygon fill="#ad0000" stroke="none" points="1,2 25,2 25,10 1,10"/><text x="13.0" y="8.363636"><tspan style="font:6px rtxbsc;fill:white;text-anchor: middle"><tspan style="letter-spacing:-0.01em">S</tspan><tspan style="letter-spacing:-0.05em">t</tspan><tspan style="letter-spacing:-0.05em">a</tspan><tspan style="letter-spacing:0">cken</tspan></tspan></text><polygon fill="#860000" stroke="none" points="0,1 26,1 25,2 1,2"/><polygon fill="#860000" stroke="none" points="1,10 25,10 26,11 0,11"/></svg>

svg-tools.lisp

@@ -0,0 +1,64 @@
+(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*))