alt-hack0/generator.ros - Recently Written

generator.ros (4784 bytes)
1 #!/bin/sh
2 #|-*- mode:lisp -*-|#
3 #|
4 exec ros -Q -- $0 "$@"
5 |#
6 (progn ;;init forms
7   (ros:ensure-asdf)
8   #+quicklisp(ql:quickload '(:alexandria :str :uiop :let-over-lambda)
9                            :silent t)
10   (asdf:load-system :utils) ;My utilities, has the COLLECT macro.
11   )
12 
13 (defpackage :ros.script.generator.3783095582
14   (:use :cl)
15   (:import-from
16    :alexandria
17    :flatten
18    :compose)
19   (:import-from :str :concat)
20   (:import-from :utils :collect :group :mapatoms)
21   (:import-from
22    :uiop
23    :copy-file
24    :resolve-symlinks
25    :directory-files
26    :subdirectories
27    :run-program))
28 (in-package :ros.script.generator.3783095582)
29 ;;; Uses a magic symlinks to deal with directories. Make sure they exist in your
30 ;;; toplevel:
31 ;;; - tt-hinting (in hack/post_processing)
32 ;;; - glyphs (in alt-hack)
33 ;;; - source (in hack)
34 ;;; - hack
35 (defvar *weights* '("Bold" "BoldItalic" "Italic" "Regular"))
36 
37 (defun uncomment (spec)
38   (remove-if #'(lambda (item)
39                  (and (stringp item)
40                       (= 1 (length item))))
41              spec))
42 
43 (defparameter *groups*
44   (mapcar #'uncomment
45    '((curve "u0028-curved" "("
46       "u0029-curved" ")")
47      (round "u0028-rounder" "("
48       "u0029-rounder" ")")
49      (backslash "u0030-backslash" "0")
50      (diamond "u0030-diamond" "0")
51      (dot "u0030-dotted" "0")
52      (forwardslash "u0030-forwardslash" "0")
53      (noslab1 "u0031-noslab" "1")
54      (flattop3 "u0033-flattop" "3")
55      (wider "u003C-wider" "<"
56       "u003E-wider" ">")
57      (knife "u0066-knife" "f")
58      (slabi "u0069-slab" "i"
59       "u00EC-slab" "ì"
60       "u00ED-slab" "í"
61       "u00EE-slab" "î"
62       "u00EF-slab" "ï"
63       "u0129-slab" "ĩ"
64       "u012B-slab" "ī"
65       "u012D-slab" "ĭ"
66       "u012F-slab" "į"
67       "u0131-slab" "ı"
68       "u0456-slab" "і"
69       "u0457-slab" "ї")))
70   "Things you actually want to permute together.")
71 
72 (defun find-keyword (keyword group)
73   (when (not (null group))
74     (let ((c (car group)))
75       (if (eql keyword (car c))
76           c
77           (find-keyword keyword (cdr group))))))
78 
79 (defun folders (keyword)
80   (cdr (find-keyword keyword *groups*)))
81 
82 (defun pprint-letters (letter-alist)
83   (dolist (p letter-alist)
84     (format t "~S ~S~%"
85             (car p) (string (cdr p)))))
86 
87 (defun show-characters ()
88   (let ((dirs (subdirectories "glyphs")))
89     (pprint-letters
90      (collect (d dirs)
91        (let ((mat (car (last (pathname-directory d)))))
92          (cons mat
93                (code-char (read (make-string-input-stream
94                                  (concat "#x"
95                                          (subseq mat 1 (search "-" mat))))))))))))
96 
97 (defun help ()
98   (format t "~@{~A~%~}"
99           "generator.ros SPEC+"
100           "SPEC should be a list of:")
101   (format t "~{~T~A~%~}"
102           (remove-if #'stringp (flatten *groups*))))
103 
104 (defun remove-hints ()
105   (let ((files (directory-files #P"tt-hinting")))
106     (dolist (f files)
107       (with-open-file (si f :direction :input)
108         (with-open-file (so f :direction :output
109                               :if-exists :supersede)
110           (let ((line (read-line si nil nil)))
111             (when (and line (char/= #\#(elt line 0)))
112               (write-line (format nil "# ~S~%" line) so))))))))
113 
114 (defun put-glyphs! (ufolders)
115   (dolist (arg ufolders)
116     (dolist (weight *weights*)
117       (dolist (f (uiop:directory-files
118                   (concat "glyphs/" arg "/"
119                           (string-downcase weight) "/")))
120         (copy-file f
121                    (concat "hack/" "source/Hack-" weight
122                            ".ufo/glyphs/"
123                            (concat (pathname-name f) "."
124                                    (pathname-type f))))))))
125 (defun make-it (&optional subcommand)
126   ;; Cannot use uiop:launch-program since it is asynchronous.
127   (run-program (if subcommand
128                       (list "make" subcommand)
129                       "make")
130                   :output *standard-output*
131                   :directory (resolve-symlinks #P"hack")
132                   :error-output *standard-output*))
133 (defun build (&rest make-commands)
134   (dolist (m make-commands)
135     (make-it m)))
136 
137 (defun verify (spec)
138   (not (set-difference spec (mapcar #'car *groups*))))
139 
140 (defun main (&rest argv)
141   (declare (ignorable argv))
142   (let ((f (first argv)))
143     (if (or (null argv)
144             (search "-?" f)
145             (search "--help" f)
146             (search "-h" f))
147         (help)
148         (let ((argv (mapcar (compose #'intern #'string-upcase) argv)))
149           (when (verify argv)
150             (remove-hints)
151             (mapc #'put-glyphs!
152                   (mapcar #'folders argv))
153             ;; Can't get woff2 on my system.
154             ;; (make-it "woff2")
155             ;; (make-it)
156             (build "ttf" "woff"))))))
157 
158 ;;; vim: set ft=lisp lisp: