commit 44985c219c8c35e6f079ce578751b5f144c3e24f Author: John Lorentzson Date: Thu May 22 11:25:48 2025 +0200 Initial commit 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 0000000..b7b71d6 Binary files /dev/null and b/stacken.woff2 differ 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*))