Skip to content

Commit 4c61991

Browse files
phantomicsphantomics
committed
normalize idiom building, continue work on Uzuki
1 parent b1929d3 commit 4c61991

File tree

12 files changed

+234
-163
lines changed

12 files changed

+234
-163
lines changed

‎extensions/uzuki/README.md

+9
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,9 @@
1+
# Uzuki: An April Japanese Kanji Extension
2+
### _Your Name <[email protected]>_
3+
4+
This extension to April provides Japanese aliases of its characters.
5+
6+
## License
7+
8+
Specify license here
9+

‎libraries/extensions/jkanji/april-ext.jkanji.asd ‎extensions/uzuki/april-xt.uzuki.asd

+3-3
Original file line numberDiff line numberDiff line change
@@ -1,11 +1,11 @@
1-
;;;; april-ext.jkanji.asd
1+
;;;; april-xt.uzuki.asd
22

3-
(asdf:defsystem #:april-ext.jkanji
3+
(asdf:defsystem #:april-xt.uzuki
44
:description "An extension to April aliasing the lexicon with Japanese kanji."
55
:author "Andrew Sengul"
66
:license "Apache-2.0"
77
:version "1.0"
88
:serial t
99
:depends-on ("april")
1010
:components ((:file "package")
11-
(:file "jkanji")))
11+
(:file "uzuki")))

‎libraries/extensions/jkanji/package.lisp ‎extensions/uzuki/package.lisp

+1-1
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
11
;;;; package.lisp
22

3-
(defpackage #:april-ext.jkanji
3+
(defpackage #:april-xt.uzuki
44
(:use #:cl #:april #:april.idiom-extension-tools))

‎libraries/extensions/jkanji/jkanji.lisp ‎extensions/uzuki/uzuki.lisp

+6-5
Original file line numberDiff line numberDiff line change
@@ -1,14 +1,15 @@
1-
;;;; april-ext.jkanji.lisp
1+
;;;; uzuki.lisp
22

3-
(in-package #:april-ext.jkanji)
3+
(in-package #:april-xt.uzuki)
44

55
"An extension to April mapping Japanese kanji to the standard APL lexicon."
66

77
(extend-vex-idiom
88
april::april
9+
(system :closure-wrapping "（()）" :function-wrapping "｛{}｝" :axis-wrapping "［[]］")
910
(utilities :process-fn-op-specs #'process-fnspecs)
1011
(functions (with (:name :japanese-kanji-function-aliases))
11-
(\＋ (has :title "プラス") ;; ｛［（）］｝ ･ ￣ ＇
12+
(\＋ (has :title "プラス") ;; ･ ￣＇
1213
(alias-of +)) ;; ×⌹.←→
1314
(\－ (has :title "マイナス")
1415
(alias-of -))
@@ -70,9 +71,9 @@
7071
(alias-of ⍸))
7172
(付 (has :title "付ける／フ")
7273
(alias-of \,))
73-
(立 (has :title "ダイ") ;; meaning fits?
74+
(立 (has :title "立つ／リツ")
7475
(alias-of ⍪))
75-
(取 (has :title "取る")
76+
(取 (has :title "取る／シュ")
7677
(alias-of ↑))
7778
(落 (has :title "落とす／ラク")
7879
(alias-of ↓))

‎grammar.lisp

+1-1
Original file line numberDiff line numberDiff line change
@@ -1207,7 +1207,7 @@
12071207
;; by looking for the . character and checking for the presence of the function
12081208
;; NOTE: this is predicated on the . character being used as the path separator
12091209
function (let* ((fn-str (string (second function)))
1210-
(dot-pos (position #\. fn-str)))
1210+
(dot-pos (position #\. fn-str :test #'char=)))
12111211
(if (not (and dot-pos (fboundp (intern fn-str space))))
12121212
function `(function (inwsd ,(second function))))))))
12131213
(when (and (listp symbol) (eql 'nspath (first symbol)))

‎libraries/extensions/jkanji/README.md

-9
This file was deleted.

‎spec.lisp

+82-54
Original file line numberDiff line numberDiff line change
@@ -40,8 +40,10 @@
4040
:workspace-defaults '(:index-origin 1 :print-precision 10 :division-method 0
4141
:comparison-tolerance double-float-epsilon
4242
:rngs (list :generators :rng (aref *rng-names* 1)))
43-
:variables *system-variables* :closure-wrapping "()" :function-wrapping "{}"
44-
:axis-wrapping "[]")
43+
:variables *system-variables* :string-delimiters "'\"" :comment-delimiters "⍝"
44+
:closure-wrapping "()" :function-wrapping "{}" :axis-wrapping "[]"
45+
:negative-signs "¯" :number-spacers "_"
46+
:axis-separators ";；" :path-separators ".．")
4547

4648
;; parameters for describing and documenting the idiom in different ways; currently, these options give
4749
;; the order in which output from the blocks of tests is printed out for the (test) and (demo) options
@@ -64,75 +66,101 @@
6466
:match-newline-character (lambda (char) (member char '(#\⋄ #\◊ #\Newline #\Return) :test #'char=))
6567
;; set the language's valid blank, newline characters and token characters
6668
:match-numeric-character
67-
(lambda (char) (or (digit-char-p char) (position char ".．_¯eEjJrR")))
69+
(lambda (char) (or (digit-char-p char) (position char ".．_¯eEjJrR" :test #'char=)))
6870
:match-token-character
6971
(lambda (char) (or (is-alphanumeric char)
70-
(position char ".．_⎕∆⍙¯")))
72+
(position char ".．_⎕∆⍙¯" :test #'char=)))
7173
;; match characters that can only appear in homogenous symbols, this is needed so that
7274
;; things like ⍺⍺.⍵⍵, ⍺∇⍵ or ⎕NS⍬ can work without spaces between the symbols
73-
:match-uniform-token-character (lambda (char) (position char "⍺⍵⍶⍹∇⍬"))
75+
:match-uniform-token-character (lambda (char) (position char "⍺⍵⍶⍹∇⍬" :test #'char=))
7476
;; match characters specifically representing function/operator arguments, this is needed
7577
;; so ⍵.path.to will work
76-
:match-arg-token-character (lambda (char) (position char "⍺⍵⍶⍹"))
78+
:match-arg-token-character (lambda (char) (position char "⍺⍵⍶⍹" :test #'char=))
7779
;; match characters used to link parts of paths together like namespace.path.to,
7880
;; this is needed so that ⍵.path.to will work
79-
:match-path-joining-character (lambda (char) (position char ".．"))
81+
:match-path-joining-character (lambda (idiom)
82+
(let ((chars (of-system idiom :path-separators)))
83+
(lambda (char) (position char chars :test #'char=))))
8084
;; overloaded numeric characters may be functions or operators or may be part of a numeric token
8185
;; depending on their context
82-
:match-overloaded-numeric-character (lambda (char) (position char ".．"))
86+
:match-overloaded-numeric-character (lambda (char) (position char ".．" :test #'char=))
8387
;; match character(s) used to separate axes
84-
:match-axis-separating-character (lambda (char) (position char ";；"))
88+
:match-axis-separating-character (lambda (idiom)
89+
(let ((chars (of-system idiom :axis-separators)))
90+
(lambda (char) (position char chars :test #'char=))))
91+
92+
;; generate the string of matched closing and opening characters that wrap code sections;
93+
;; used to identify stray closing characters such as ) without a corresponding (
94+
:collect-delimiters
95+
(lambda (idiom)
96+
(let ((output) (cw (of-system idiom :closure-wrapping))
97+
(fw (of-system idiom :function-wrapping)) (aw (of-system idiom :axis-wrapping)))
98+
(loop :for i :from (/ (length cw) 2) :to (1- (length cw)) :do (push (aref cw i) output))
99+
(loop :for i :from (/ (length fw) 2) :to (1- (length fw)) :do (push (aref fw i) output))
100+
(loop :for i :from (/ (length aw) 2) :to (1- (length aw)) :do (push (aref aw i) output))
101+
(loop :for i :below (/ (length cw) 2) :do (push (aref cw i) output))
102+
(loop :for i :below (/ (length fw) 2) :do (push (aref fw i) output))
103+
(loop :for i :below (/ (length aw) 2) :do (push (aref aw i) output))
104+
(reverse (coerce output 'string))))
85105
;; this code preprocessor removes comments, starting with each ⍝ and ending before the next newline
86106
:prep-code-string
87-
(lambda (string)
88-
(let ((commented) (osindex 0) (comment-char #\⍝)
89-
(out-string (make-string (length string) :initial-element #\ )))
90-
(loop :for char :across string
91-
:do (if commented (when (member char '(#\Newline #\Return) :test #'char=)
92-
(setf commented nil
93-
(row-major-aref out-string osindex) char
94-
osindex (1+ osindex)))
95-
(if (char= char comment-char) (setf commented t)
96-
(setf (row-major-aref out-string osindex) char
97-
osindex (1+ osindex)))))
98-
;; return displaced string to save time processing blanks
99-
(make-array osindex :element-type 'character :displaced-to out-string)))
107+
(lambda (idiom)
108+
(let ((comment-delimiters (of-system idiom :comment-delimiters)))
109+
(lambda (string)
110+
(let ((commented) (osindex 0)
111+
(out-string (make-string (length string) :initial-element #\ )))
112+
(loop :for char :across string
113+
:do (if commented (when (member char '(#\Newline #\Return) :test #'char=)
114+
(setf commented nil
115+
(row-major-aref out-string osindex) char
116+
osindex (1+ osindex)))
117+
(if (position char comment-delimiters :test #'char=)
118+
(setf commented t)
119+
(setf (row-major-aref out-string osindex) char
120+
osindex (1+ osindex)))))
121+
;; return displaced string to save time processing blanks
122+
(make-array osindex :element-type 'character :displaced-to out-string)))))
100123
;; handles axis strings like "'2;3;;' from 'array[2;3;;]'"
101124
:process-axis-string
102-
(lambda (string)
103-
(let ((indices) (last-index) (quoted)
104-
(nesting (vector 0 0 0))
105-
(delimiters "[({])}")
106-
(dllen-plus 7) ;; 1 plus the number of delimiters
107-
(quote-delimiter #\'))
108-
(loop :for char :across string :counting char :into charix
109-
:do (let ((mx (or (loop :for d :across delimiters :counting d :into dx
110-
:when (char= d char) :do (return (- dllen-plus dx)))
111-
0)))
112-
(if (char= char quote-delimiter)
113-
(setf quoted (not quoted))
114-
(unless quoted
115-
(if (< 3 mx) (incf (aref nesting (- 6 mx)))
116-
(if (< 0 mx 4)
117-
(if (< 0 (aref nesting (- 3 mx)))
118-
(decf (aref nesting (- 3 mx)))
119-
(error "Each closing ~a must match with an opening ~a."
120-
(aref delimiters mx) (aref delimiters (- 3 mx))))
121-
(when (and (char= char #\;)
122-
(zerop (loop :for ncount :across nesting
123-
:summing ncount)))
124-
(setq indices (cons (1- charix) indices)))))))))
125-
(loop :for index :in (reverse (cons (length string) indices))
126-
:counting index :into iix
127-
:collect (make-array (- index (if last-index 1 0)
128-
(or last-index 0))
129-
:element-type 'character :displaced-to string
130-
:displaced-index-offset (if last-index (1+ last-index) 0))
131-
:do (setq last-index index))))
125+
(let ((delimiters) (axis-separators) (full-len) (half-len) (nesting (vector 0 0 0)))
126+
(lambda (idiom)
127+
(unless delimiters
128+
(setf delimiters (reverse (funcall (of-utilities idiom :collect-delimiters) idiom))
129+
full-len (length delimiters)
130+
half-len (/ full-len 2)
131+
axis-separators (of-system idiom :axis-separators)))
132+
(lambda (string)
133+
(let ((indices) (last-index) (quoted))
134+
(loop :for i :below (length nesting) :do (setf (aref nesting i) 0))
135+
(loop :for char :across string :counting char :into charix
136+
:do (let ((mx (or (loop :for d :across delimiters :counting d :into dx
137+
:when (char= d char) :do (return (- full-len -1 dx)))
138+
0)))
139+
(if (position char (of-system idiom :string-delimiters) :test #'char=)
140+
(setf quoted (not quoted))
141+
(unless quoted
142+
(if (< half-len mx) (incf (aref nesting (- full-len mx)))
143+
(if (<= 1 mx half-len)
144+
(if (< 0 (aref nesting (- half-len mx)))
145+
(decf (aref nesting (- half-len mx)))
146+
(error "Each closing ~a must match with an opening ~a."
147+
(aref delimiters mx)
148+
(aref delimiters (- half-len mx))))
149+
(when (and (position char axis-separators :test #'char=)
150+
(zerop (loop :for ncount :across nesting
151+
:summing ncount)))
152+
(setq indices (cons (1- charix) indices)))))))))
153+
(loop :for index :in (reverse (cons (length string) indices))
154+
:counting index :into iix
155+
:collect (make-array (- index (if last-index 1 0)
156+
(or last-index 0))
157+
:element-type 'character :displaced-to string
158+
:displaced-index-offset (if last-index (1+ last-index) 0))
159+
:do (setq last-index index))))))
132160
;; macro to process lexical specs of functions and operators
133161
:process-fn-op-specs #'process-fnspecs
134162
:test-parameters '((:space unit-test-staging))
135-
:format-number #'parse-apl-number-string
163+
:build-number-formatter #'generate-apl-number-string-parser
136164
:format-value #'format-value
137165
;; process system state input passed as with (april (with (:state ...)) "...")
138166
:preprocess-state-input
@@ -273,7 +301,7 @@
273301
(is "÷2 4 8" #(1/2 1/4 1/8))
274302
(is "{⎕div←0 ⋄ ÷⍨⍵} 0" 1)
275303
(is "{⎕div←1 ⋄ ÷⍨⍵} 0" 0)
276-
(is "{⎕div←1 ⋄ ÷⍵} 0" 0)))
304+
(is "{⎕div←1 ⋄ ÷ ⍵} 0" 0)))
277305
(⋆ (has :titles ("Exponential" "Power") :aliases (*))
278306
(ambivalent (scalar-function apl-exp)
279307
(scalar-function (reverse-op :dyadic apl-expt)))

0 commit comments

Comments
 (0)