commit a09b18297800b617b3e407f952f0ce5ad2c999ec Spenser Truex <truex@equwal.com> 2023-08-10 13:15:50 -0300 Add bc scripts
Hack | 1 + all-fonts-bc.lisp | 37 +++++++++ generator-bc.ros | 243 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ script-bc.lisp | 4 + 4 files changed, 285 insertions(+)
diff --git a/Hack b/Hack new file mode 120000 index 0000000..f59d596 --- /dev/null +++ b/Hack @@ -0,0 +1 @@ +/home/jose/src/repos/gh/source-foundry/hack \ No newline at end of file diff --git a/all-fonts-bc.lisp b/all-fonts-bc.lisp new file mode 100644 index 0000000..2c35da0 --- /dev/null +++ b/all-fonts-bc.lisp @@ -0,0 +1,37 @@ +(defpackage :all-fonts + (:use :cl) + (:import-from :alexandria :map-combinations) + (:import-from :uiop :run-program)) +(in-package :all-fonts) + +(defparameter *groups* + '(curve round backslash diamond dot forwardslash noslab1 flattop3 widerknife slabi slabl traditional loop nogap) + "Things you actually want to permute together.") + +(defparameter *exclusions* + '((curve round) + (backslash diamond dot forwardslash)) + "Things which you don't want specified at the same time.") + +(defun verify (spec) + "Ensure that the spec is not bogus." + (let ((group (not (set-difference spec *groups*))) + (exclusion (not (some #'identity + (mapcar #'(lambda (ex) + (<= 2 (length (intersection spec ex)))) + *exclusions*))))) + (values (and group exclusion) + (if group (if exclusion 'group-and-exclusion 'group) + (if exclusion 'exclusion 'unknown))))) +(defun gen-all-fonts () + (loop for x from 1 to (length *groups*) + do (map-combinations + (lambda (f) + (when (verify f) + (run-program (format nil "./generator-bc.ros --ttf --woff --woff2 ~(~{ ~A~}~)" f) :output t) + ;; KLUDGE: Weird bug where everything ends up in the ttf folder + (run-program (format nil "tar -vcf - Hack/build/ttf/* | xz -12 >'~(~{~A~}~).tar.xz'" f) :output t) + (run-program "rm -Rf Hack/build") + (run-program "mkdir Hack/build"))) + *groups* + :length x))) diff --git a/generator-bc.ros b/generator-bc.ros new file mode 100755 index 0000000..9e8b33b --- /dev/null +++ b/generator-bc.ros @@ -0,0 +1,243 @@ +#!/bin/sh +#|-*- mode:lisp -*-|# +#| +exec ros -Q -- $0 "$@" +|# +;;; This file (c) Spenser Truex 2021 +;;; MIT license. + +(progn ;;init forms + (ros:ensure-asdf) + #+quicklisp(ql:quickload '(:alexandria :uiop) + :silent t)) + +;;; EXAMPLE USAGE: +;;; cd alt-hack && ./generator.ros curve dot slabi +(defpackage :ros.script.generator.3783095582 + (:use :cl)) +(in-package :ros.script.generator.3783095582) +(defvar *weights* '("Bold" "BoldItalic" "Italic" "Regular")) + +(defun uncomment (spec) + (remove-if #'(lambda (item) + (and (stringp item) + (= 1 (length item)))) + spec)) + +(defparameter *helpful-groups* + '(;; Barry Cohen's additions + (slabl "u006C-slab" "l" + "u013C-slab" "ļ" + "u013E-slab" "ľ" + "u0142-slab" "ł" + "u013A-slab" "ĺ" + "u0140-slab" "ŀ") + (traditional "u0025-traditional" "%") + (nogap "u0026-nogap" "&") + (loop "u0067-loop" "g" + "u0123-loop" "ǵ" + "u011F-loop" "ğ" + "u01E7-loop" "ǧ" + "u0121-loop" "ġ" + "u011D-loop" "ĝ") + (curve "u0028-curved" "(" + "u0029-curved" ")") + (round "u0028-rounder" "(" + "u0029-rounder" ")") + (backslash "u0030-backslash" "0") + (diamond "u0030-diamond" "0") + (dot "u0030-dotted" "0") + (forwardslash "u0030-forwardslash" "0") + (noslab1 "u0031-noslab" "1") + (flattop3 "u0033-flattop" "3") + (wider "u003C-wider" "<" + "u003E-wider" ">") + (knife "u0066-knife" "f") + (slabi "u0069-slab" "i" + "u00EC-slab" "ì" + "u00ED-slab" "í" + "u00EE-slab" "î" + "u00EF-slab" "ï" + "u0129-slab" "ĩ" + "u012B-slab" "ī" + "u012D-slab" "ĭ" + "u012F-slab" "į" + "u0131-slab" "ı" + "u0456-slab" "і" + "u0457-slab" "ї")) + "Groups with extra information for user help.") + +(defun prune (test tree) + (labels ((rec (tree acc) + (cond + ((null tree) (nreverse acc)) + ((consp (car tree)) + (rec (cdr tree) + (cons (rec (car tree) nil) acc))) + (t (rec (cdr tree) + (if (funcall test (car tree)) + acc + (cons (car tree) acc))))))) + (rec tree nil))) + +(defun pprint-helpful-groups () + (let ((more-helpful (prune #'(lambda (s) + (and (stringp s) + (< 1 (length s)))) + *helpful-groups*))) + (loop for g in more-helpful + do (format t "~A:~%" (car g)) + do (format t "~{~A ~}~%" (cdr g))))) +(defparameter *groups* + (mapcar #'uncomment *helpful-groups*) + "Things you actually want to permute together.") +(defparameter *exclusions* + '((curve round) + (backslash diamond dot forwardslash)) + "Things which you don't want specified at the same time.") +(defparameter *formats* + '("ttf" "woff" "woff2") + "Valid parameters to call as formats.") + +(define-symbol-macro help + (progn (pprint-lines + "generator.ros OPTIONS* {SHOW | SPEC+}") + (format t "These are valid OPTIONS: ~{~A ~}~%" + (mapcar #'(lambda (f) (concatenate 'string "--" f)) + *formats*)) + (pprint-lines "SPEC should be a list of:") + (pprint-helpful-groups) + (pprint-lines + "Keep in mind that it makes no sense to include" + "the same character spec twice." + "SHOW just finds all available glyphs in alt-hack." + "TEST runs the test functions for ttf, woff and woff2."))) + +(defun find-keyword (keyword group) + (when (not (null group)) + (let ((c (car group))) + (if (eql keyword (car c)) + c + (find-keyword keyword (cdr group)))))) + +(defun folders (keyword) + (cdr (find-keyword keyword *groups*))) + +(defun pprint-lines (&rest strings) + (format t "~{~A~%~}" strings)) + +(defun remove-hints () + (let ((files (uiop:directory-files #P"Hack/postbuild_processing/tt-hinting"))) + (dolist (f files) + (with-open-file (si f :direction :input) + (with-open-file (so f :direction :output + :if-exists :supersede) + (let ((line (read-line si nil nil))) + (when (and line (char/= #\#(elt line 0))) + (write-line (format nil "# ~S~%" line) so)))))))) + +(defun put-glyphs! (ufolders) + (dolist (arg ufolders) + (dolist (weight *weights*) + (dolist (f (uiop:directory-files + (concatenate 'string "glyphs/" arg "/" + (string-downcase weight) "/"))) + (uiop:copy-file f + (concatenate 'string + "Hack/source/Hack-" + weight + ".ufo/glyphs/" + (pathname-name f) + "." + (pathname-type f))))))) +(defun make-it (&optional subcommand) + ;; Cannot use uiop:launch-program since it is asynchronous. + (uiop:run-program (if subcommand + (list "make" subcommand) + "make") + :output *standard-output* + :directory #P"Hack" + :error-output *standard-output*)) +(defun build (&rest make-commands) + (dolist (m make-commands) + (make-it m))) + +(defun verify (spec) + "Ensure that the spec is not bogus." + (let ((group (not (set-difference spec (mapcar #'car *groups*)))) + (exclusion (not (some #'identity + (mapcar #'(lambda (ex) + (<= 2 (length (intersection spec ex)))) + *exclusions*))))) + (values (and group exclusion) + (if group (if exclusion 'group-and-exclusion 'group) + (if exclusion 'exclusion 'unknown))))) + +(defun show-characters () + (flet ((pprint-letters (letter-alist) + (dolist (p letter-alist) + (format t "~T~A~T~A~%" + (string (cdr p)) (car p))))) + (let ((dirs (uiop:subdirectories "glyphs"))) + (pprint-letters + (loop + for d in dirs + collecting + (let ((mat (car (last (pathname-directory d))))) + (cons + mat + (code-char (read-from-string + (concatenate 'string + "#x" + (subseq mat 1 (search "-" mat)))))))))))) +(defun format-parser (argv) + (when argv + (let ((c (car argv))) + (when (and (< 2 (length c)) + (string= "--" (subseq c 0 2))) + (cons (subseq c 2) (format-parser (cdr argv))))))) +(defun should-help (argv) + (or (null argv) + (dolist (a argv) + (when (or (search "-?" a) + (search "-h" a) + (search "help" a)) + (return t))))) +(defun should-test (argv) + (string= (car argv) "test")) + +(define-symbol-macro test + (progn (format t "Helping you:~%") + (main "help") + (format t "~%DONE. Trying TTF.") + (main "--ttf") + (format t "~%DONE. Trying WOFF.") + (main "--woff") + (format t "~%DONE. Trying WOFF2.") + (main "--woff2"))) + +(defun main (&rest argv) + (declare (ignorable argv)) + (if (should-help argv) + help + (if (should-test argv) + test + (let ((formats (format-parser argv))) + (let ((argv (mapcar (lambda (g) (intern (string-upcase g))) + (nthcdr (length formats) argv))) + (formats (or formats "ttf woff woff2"))) + (if (and argv (string= "SHOW" (string-upcase (car argv)))) + (show-characters) + (multiple-value-bind (bool name) + (verify argv) + (if bool + (progn (remove-hints) + (mapc #'put-glyphs! + (mapcar #'folders argv)) + ;; Can't get woff2 on my system. + (mapc #'build formats)) + (progn (format t "Invalid ~S in spec: ~{~A ~}~%" + name + argv)))))))))) + +;;; vim: set ft=lisp lisp: diff --git a/script-bc.lisp b/script-bc.lisp new file mode 100644 index 0000000..cda6908 --- /dev/null +++ b/script-bc.lisp @@ -0,0 +1,4 @@ +(ql:quickload :alexandria) +(ql:quickload :uiop) +(load "all-fonts-bc.lisp") +(all-fonts::gen-all-fonts)