trial/prompt-gen.lisp at master · Shirakumo/trial · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
#|
exec sbcl \
  --noinform \
  --disable-debugger \
  --eval "(ql:quickload '(com.inuoe.jzon) :silent T)" \
  --load "$0" \
  --eval "(org.shirakumo.fraf.trial.promptgen::main)" \
  --quit \
  --end-toplevel-options "${@:1}"
|#
(defpackage #:org.shirakumo.fraf.trial.promptgen
  (:use #:cl)
  (:export))
(in-package #:org.shirakumo.fraf.trial.promptgen)

(defvar *glyphs*)
(defvar *tags*)
(defvar *categories*)

(defun kw (thing)
  (intern (string-upcase thing) "KEYWORD"))

(defun strip-name (name &rest prefixes)
  (let ((name (string name)))
    (dolist (prefix prefixes name)
      (let ((prefix (string prefix)))
        (when (< (length prefix) (length name))
          (or (when (and (string= prefix name :end2 (length prefix))
                         (char= #\- (char name (length prefix))))
                (setf name (subseq name (1+ (length prefix)))))
              (when (and (string= prefix name :start2 (- (length name) (length prefix)))
                         (char= #\- (char name (- (length name) (length prefix) 1))))
                (setf name (subseq name 0 (- (length name) (length prefix) 1))))))))))

(defun parse (file)
  (let ((glyphs (com.inuoe.jzon:parse file))
        (tag-map (make-hash-table :test 'eql))
        (category-map (make-hash-table :test 'eql))
        (name-map (make-hash-table :test 'eql)))
    (loop for glyph across glyphs
          for code-name = (kw (gethash "code-name" glyph))
          for category = (kw (gethash "category" glyph))
          for cp = (gethash "codepoint" glyph)
          do (setf (gethash code-name name-map) cp)
             (cond ((eql category :alphabet)
                    (push (list (kw (gethash "character" glyph)) cp) (gethash category category-map)))
                   (T
                    (push code-name (gethash category category-map))
                    (loop for tag across (gethash "tags" glyph)
                          do (push code-name (gethash (kw tag) tag-map))))))
    (values (setf *glyphs* name-map)
            (setf *tags* tag-map)
            (setf *categories* category-map))))

(defun map-name (name)
  (case name
    ((:plus :dualsense-options :options :menu) :select)
    ((:minus :dualsense-share :share :view) :start)
    ((:icon-playstation :icon-xbox :icon :icon-nintendo :sony-touchpad) :home)
    (:left-shoulder :l1)
    (:right-shoulder :r1)
    (:left-trigger :l2)
    (:right-trigger :r2)
    (:analog-l-click :l3)
    (:analog-r-click :r3)
    (:alt-l :left-alt)
    (:alt-r :right-alt)
    (:control-l :left-control)
    (:control-r :right-control)
    (:shift-l :left-shift)
    (:shift-r :right-shift)
    (T name)))

(defun table-def (table names &optional extras)
  (let ((table-name (if (listp table) (first table) table)))
    `(define-glyph-table ,table
       ,@(loop for name in names
               collect (list (map-name (kw (apply #'strip-name name
                                                  table-name :ascii
                                                  (loop for cat being the hash-keys of *categories*
                                                        collect cat))))
                             (gethash name *glyphs*)))
       ,@extras)))

(defun category-table-def (category &optional extras)
  (table-def category (gethash (if (listp category) (first category) category) *categories*) extras))

(defun tag-table-def (tag &optional extras)
  (table-def tag (gethash (if (listp tag) (first tag) tag) *tags*) extras))

(defun all-table-defs ()
  (list (category-table-def :device)
        (category-table-def :icon)
        (category-table-def :logo)
        (category-table-def :mouse)
        (category-table-def :keyboard
                            (gethash :alphabet *categories*))
        (category-table-def :gamepad)
        (tag-table-def '(:xbox :inherit :gamepad))
        (tag-table-def '(:sony :inherit :gamepad))
        (tag-table-def '(:nintendo :inherit :gamepad))
        (tag-table-def '(:steam :inherit :gamepad))))

(defun write-prompt-table (table &optional (stream T))
  (destructuring-bind (def name &rest body) table
    (format stream "(~a ~s~{~%  (~{~30s #x~x~})~})~%" def name body)))

(defun write-prompt-tables (&optional (tables (all-table-defs)) (file #p"prompt-tables.lisp"))
  (let ((file (merge-pathnames file #.(or *compile-file-pathname* *load-pathname*)))
        (*print-case* :downcase))
    (with-open-file (stream file :direction :output :if-exists :supersede)
      (format stream ";;;; Prompt Glyph Tables -- Autogenerated by prompt-gen.lisp~%")
      (format stream "(in-package #:org.shirakumo.fraf.trial)~%")
      (dolist (table tables)
        (terpri stream)
        (write-prompt-table table stream)))))

(defun main ()
  (format *query-io* "~&Please enter the path to the promptfont glyphs.json file:~%")
  (parse (pathname (read-line *query-io*)))
  (write-prompt-tables)
  (format *query-io* "~&prompt-tables.lisp updated.~%"))