alt-hack0/generator-bc.ros - Recently Written

generator-bc.ros (8345 bytes)
1 #!/bin/sh
2 #|-*- mode:lisp -*-|#
3 #|
4 exec ros -Q -- $0 "$@"
5 |#
6 ;;; This file (c) Spenser Truex 2021
7 ;;; MIT license.
8 
9 (progn ;;init forms
10   (ros:ensure-asdf)
11   #+quicklisp(ql:quickload '(:alexandria :uiop)
12                            :silent t))
13 
14 ;;; EXAMPLE USAGE:
15 ;;; cd alt-hack && ./generator.ros curve dot slabi
16 (defpackage :ros.script.generator.3783095582
17   (:use :cl))
18 (in-package :ros.script.generator.3783095582)
19 (defvar *weights* '("Bold" "BoldItalic" "Italic" "Regular"))
20 
21 (defun uncomment (spec)
22   (remove-if #'(lambda (item)
23                  (and (stringp item)
24                       (= 1 (length item))))
25              spec))
26 
27 (defparameter *helpful-groups*
28   '(;; Barry Cohen's additions
29     (slabl "u006C-slab" "l"
30            "u013C-slab" "ļ"
31            "u013E-slab" "ľ"
32            "u0142-slab" "ł"
33            "u013A-slab" "ĺ"
34            "u0140-slab" "ŀ")
35     (traditional "u0025-traditional" "%")
36     (nogap "u0026-nogap" "&")
37     (loop "u0067-loop" "g"
38           "u0123-loop" "ǵ"
39           "u011F-loop" "ğ"
40           "u01E7-loop" "ǧ"
41           "u0121-loop" "ġ"
42           "u011D-loop" "ĝ")
43     (curve "u0028-curved" "("
44      "u0029-curved" ")")
45     (round "u0028-rounder" "("
46      "u0029-rounder" ")")
47     (backslash "u0030-backslash" "0")
48     (diamond "u0030-diamond" "0")
49     (dot "u0030-dotted" "0")
50     (forwardslash "u0030-forwardslash" "0")
51     (noslab1 "u0031-noslab" "1")
52     (flattop3 "u0033-flattop" "3")
53     (wider "u003C-wider" "<"
54      "u003E-wider" ">")
55     (knife "u0066-knife" "f")
56     (slabi "u0069-slab" "i"
57      "u00EC-slab" "ì"
58      "u00ED-slab" "í"
59      "u00EE-slab" "î"
60      "u00EF-slab" "ï"
61      "u0129-slab" "ĩ"
62      "u012B-slab" "ī"
63      "u012D-slab" "ĭ"
64      "u012F-slab" "į"
65      "u0131-slab" "ı"
66      "u0456-slab" "і"
67      "u0457-slab" "ї"))
68   "Groups with extra information for user help.")
69 
70 (defun prune (test tree)
71   (labels ((rec (tree acc)
72              (cond
73                ((null tree) (nreverse acc))
74                ((consp (car tree))
75                 (rec (cdr tree)
76                      (cons (rec (car tree) nil) acc)))
77                (t (rec (cdr tree)
78                        (if (funcall test (car tree))
79                            acc
80                            (cons (car tree) acc)))))))
81     (rec tree nil)))
82 
83 (defun pprint-helpful-groups ()
84   (let ((more-helpful (prune #'(lambda (s)
85                                  (and (stringp s)
86                                       (< 1 (length s))))
87                              *helpful-groups*)))
88     (loop for g in more-helpful
89           do (format t "~A:~%" (car g))
90           do (format t "~{~A ~}~%" (cdr g)))))
91 (defparameter *groups*
92   (mapcar #'uncomment *helpful-groups*)
93   "Things you actually want to permute together.")
94 (defparameter *exclusions*
95   '((curve round)
96     (backslash diamond dot forwardslash))
97   "Things which you don't want specified at the same time.")
98 (defparameter *formats*
99   '("ttf" "woff" "woff2")
100   "Valid parameters to call as formats.")
101 
102 (define-symbol-macro help
103     (progn (pprint-lines
104             "generator.ros OPTIONS* {SHOW | SPEC+}")
105            (format t "These are valid OPTIONS: ~{~A ~}~%"
106                    (mapcar #'(lambda (f) (concatenate 'string "--" f))
107                            *formats*))
108            (pprint-lines "SPEC should be a list of:")
109            (pprint-helpful-groups)
110            (pprint-lines
111             "Keep in mind that it makes no sense to include"
112             "the same character spec twice."
113             "SHOW just finds all available glyphs in alt-hack."
114             "TEST runs the test functions for ttf, woff and woff2.")))
115 
116 (defun find-keyword (keyword group)
117   (when (not (null group))
118     (let ((c (car group)))
119       (if (eql keyword (car c))
120           c
121           (find-keyword keyword (cdr group))))))
122 
123 (defun folders (keyword)
124   (cdr (find-keyword keyword *groups*)))
125 
126 (defun pprint-lines (&rest strings)
127   (format t "~{~A~%~}" strings))
128 
129 (defun remove-hints ()
130   (let ((files (uiop:directory-files #P"Hack/postbuild_processing/tt-hinting")))
131     (dolist (f files)
132       (with-open-file (si f :direction :input)
133         (with-open-file (so f :direction :output
134                               :if-exists :supersede)
135           (let ((line (read-line si nil nil)))
136             (when (and line (char/= #\#(elt line 0)))
137               (write-line (format nil "# ~S~%" line) so))))))))
138 
139 (defun put-glyphs! (ufolders)
140   (dolist (arg ufolders)
141     (dolist (weight *weights*)
142       (dolist (f (uiop:directory-files
143                   (concatenate 'string "glyphs/" arg "/"
144                                (string-downcase weight) "/")))
145         (uiop:copy-file f
146                    (concatenate 'string
147                                 "Hack/source/Hack-"
148                                 weight
149                                 ".ufo/glyphs/"
150                                 (pathname-name f)
151                                 "."
152                                 (pathname-type f)))))))
153 (defun make-it (&optional subcommand)
154   ;; Cannot use uiop:launch-program since it is asynchronous.
155   (uiop:run-program (if subcommand
156                       (list "make" subcommand)
157                       "make")
158                   :output *standard-output*
159                   :directory #P"Hack"
160                   :error-output *standard-output*))
161 (defun build (&rest make-commands)
162   (dolist (m make-commands)
163     (make-it m)))
164 
165 (defun verify (spec)
166   "Ensure that the spec is not bogus."
167   (let ((group (not (set-difference spec (mapcar #'car *groups*))))
168         (exclusion (not (some #'identity
169                     (mapcar #'(lambda (ex)
170                                 (<= 2 (length (intersection spec ex))))
171                             *exclusions*)))))
172     (values (and group exclusion)
173             (if group (if exclusion 'group-and-exclusion 'group)
174                 (if exclusion 'exclusion 'unknown)))))
175 
176 (defun show-characters ()
177   (flet ((pprint-letters (letter-alist)
178            (dolist (p letter-alist)
179              (format t "~T~A~T~A~%"
180                      (string (cdr p)) (car p)))))
181     (let ((dirs (uiop:subdirectories "glyphs")))
182       (pprint-letters
183        (loop
184          for d in dirs
185          collecting
186          (let ((mat (car (last (pathname-directory d)))))
187            (cons
188             mat
189             (code-char (read-from-string
190                         (concatenate 'string
191                                      "#x"
192                                 (subseq mat 1 (search "-" mat))))))))))))
193 (defun format-parser (argv)
194   (when argv
195     (let ((c (car argv)))
196       (when (and (< 2 (length c))
197                  (string= "--" (subseq c 0 2)))
198        (cons (subseq c 2) (format-parser (cdr argv)))))))
199 (defun should-help (argv)
200   (or (null argv)
201       (dolist (a argv)
202         (when (or (search "-?" a)
203                   (search "-h" a)
204                   (search "help" a))
205           (return t)))))
206 (defun should-test (argv)
207   (string= (car argv) "test"))
208 
209 (define-symbol-macro test
210     (progn (format t "Helping you:~%")
211            (main "help")
212            (format t "~%DONE. Trying TTF.")
213            (main "--ttf")
214            (format t "~%DONE. Trying WOFF.")
215            (main "--woff")
216            (format t "~%DONE. Trying WOFF2.")
217            (main "--woff2")))
218 
219 (defun main (&rest argv)
220   (declare (ignorable argv))
221   (if (should-help argv)
222       help
223       (if (should-test argv)
224           test
225           (let ((formats (format-parser argv)))
226             (let ((argv (mapcar (lambda (g) (intern (string-upcase g)))
227                                 (nthcdr (length formats) argv)))
228                   (formats (or formats "ttf woff woff2")))
229               (if (and argv (string= "SHOW" (string-upcase (car argv))))
230                   (show-characters)
231                   (multiple-value-bind (bool name)
232                       (verify argv)
233                     (if bool
234                         (progn (remove-hints)
235                                (mapc #'put-glyphs!
236                                      (mapcar #'folders argv))
237                                ;; Can't get woff2 on my system.
238                                (mapc #'build formats))
239                         (progn (format t "Invalid ~S in spec: ~{~A ~}~%"
240                                        name
241                                        argv))))))))))
242 
243 ;;; vim: set ft=lisp lisp: