From 44985c219c8c35e6f079ce578751b5f144c3e24f Mon Sep 17 00:00:00 2001 From: John Lorentzson Date: Thu, 22 May 2025 11:25:48 +0200 Subject: [PATCH] Initial commit --- Makefile | 8 +++++ balken.lisp | 77 +++++++++++++++++++++++++++++++++++++++++++++++++ nya-balken.asd | 12 ++++++++ package.lisp | 5 ++++ stacken.svg | 1 + stacken.woff2 | Bin 0 -> 1176 bytes svg-tools.lisp | 64 ++++++++++++++++++++++++++++++++++++++++ 7 files changed, 167 insertions(+) create mode 100644 Makefile create mode 100644 balken.lisp create mode 100644 nya-balken.asd create mode 100644 package.lisp create mode 100644 stacken.svg create mode 100644 stacken.woff2 create mode 100644 svg-tools.lisp diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..0be999c --- /dev/null +++ b/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)" > $@ diff --git a/balken.lisp b/balken.lisp new file mode 100644 index 0000000..c9ade2f --- /dev/null +++ b/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))) diff --git a/nya-balken.asd b/nya-balken.asd new file mode 100644 index 0000000..6c281e4 --- /dev/null +++ b/nya-balken.asd @@ -0,0 +1,12 @@ +(in-package #:asdf-user) + +(defsystem #:nya-balken + :version "0.1.0" + :author "John Lorentzson " + :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"))) diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..d49dcd9 --- /dev/null +++ b/package.lisp @@ -0,0 +1,5 @@ +(in-package #:cl-user) + +(defpackage #:se.kth.stacken.nya-balken + (:use #:cl) + (:export #:main #:make-beam)) diff --git a/stacken.svg b/stacken.svg new file mode 100644 index 0000000..2efd683 --- /dev/null +++ b/stacken.svg @@ -0,0 +1 @@ +Stacken \ No newline at end of file diff --git a/stacken.woff2 b/stacken.woff2 new file mode 100644 index 0000000000000000000000000000000000000000..b7b71d6e8474a0f096133e8379562274f933480e GIT binary patch literal 1176 zcmV;J1ZVqqPew8T0RR9100fu-4FCWD00`g!00cn*0RR9100000000000000000000 z0000#Mn+Uk92y=5Rse!z5eN!~NQEN{761V@0we<{1Rw>2NC!3>J_i6Eg>l1OT3cd> zqhK<4`s3lBwSM=_?9LZ4pb-kqEvZKjg+s#|O~jj-gd)B_kEgw4&Y$=*WF)%|V0!0v zP}lhYvF88h|8j@h?*rYKX!rbtmdzC%7L_epMhW(!vHY;pwn3T&Bmqc>S-X-_@?h62 zJNW3Xu6rs3eAw`x1$<1bUJAg+q)rA1l%o+ygj9);LxPAa@m-!|CAlBK>e?4?*#}AC zvlLXI{9M+{dOf{# zy|v`1IHe&Xcn;Kc>oz+uh6iOc#mp_eHX*owH*wtUlTP)YA z78jZXt48P%9wt}p)(Te04;fU%or79b(A!|`SIQ#m-DUVa9l7`NjEa}8Yl1Bu4F8{F z>CK4c8Hh=KSUkLUmh$0m6gBA&u3aoS#$F^FD&NBt0!k${Deu);MiJ<*tsAgJ;5X6+5$ z@h+ACt7Py(i^>_>~M}YZf_Xr>6oGa!8UL0 zoRsDz_Sr`Hv+!qJ7iXNkEvs2NOq&?!0f0ct{m+R8xe8w2q*40ys;VPd5dY&YP%HsK zJTEZWV@~`Pgk3sX5u+P;MRJgd-GGu%kL4&9f=28P5gv`|jRXlopdSEKItT=yh7lG* zW)PAPlY~?cD}|iQ6CtnM&+VBk>WGP433`AagmS%*gcvEL2FVk0%3TxknmueTQyzKa zan-3;s#+C>BO7+|Sz&~V69ryTPwQx7mv6;{#zg@v(V#_vdK|E1SxZ4Z2VgX=LZup2 zfyQkOaW>Q1>%f6EXAKT{9Lp6M+u=?*ug=&6ftx0AR)rUh?gQ20000?I}A|( literal 0 HcmV?d00001 diff --git a/svg-tools.lisp b/svg-tools.lisp new file mode 100644 index 0000000..011250d --- /dev/null +++ b/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*))