From 605af02f902f3943c222533fb3d90836469f91b0 Mon Sep 17 00:00:00 2001
From: "Tarn W. Burton" <twburton@gmail.com>
Date: Thu, 18 Jan 2024 14:42:26 -0500
Subject: [PATCH] Add invistra-numeral

---
 .github/workflows/test.yml       |  3 ++
 code/numeral/numeral.lisp        | 86 ++++++++++++++++++++++++++++++++
 code/numeral/packages.lisp       |  3 ++
 code/numeral/test/directive.lisp | 16 ++++++
 code/numeral/test/packages.lisp  |  4 ++
 code/numeral/test/test.lisp      |  8 +++
 invistra-numeral.asd             | 34 +++++++++++++
 7 files changed, 154 insertions(+)
 create mode 100644 code/numeral/numeral.lisp
 create mode 100644 code/numeral/packages.lisp
 create mode 100644 code/numeral/test/directive.lisp
 create mode 100644 code/numeral/test/packages.lisp
 create mode 100644 code/numeral/test/test.lisp
 create mode 100644 invistra-numeral.asd

diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml
index 9d7be41..12a6e97 100644
--- a/.github/workflows/test.yml
+++ b/.github/workflows/test.yml
@@ -51,3 +51,6 @@ jobs:
     - name: Run ANSI Tests
       run: |
         lisp -i ${{ matrix.lisp }} -e "(ql:quickload :invistra-extrinsic/test)" -e "(invistra-extrinsic/test/ansi:test :exit t)"
+    - name: Run Numeral Tests
+      run: |
+        lisp -i ${{ matrix.lisp }} -e "(defparameter cl-user::*exit-on-test-failures* t)" -e "(ql:quickload :invistra-numeral/test)" -e "(parachute:test :invistra-numeral/test)"
diff --git a/code/numeral/numeral.lisp b/code/numeral/numeral.lisp
new file mode 100644
index 0000000..407f51c
--- /dev/null
+++ b/code/numeral/numeral.lisp
@@ -0,0 +1,86 @@
+(in-package #:invistra-numeral)
+
+(defclass numeral-directive (invistra:directive)
+  ((pattern :accessor numeral-pattern
+            :initarg :pattern)))
+
+(defmethod invistra:parameter-specifications ((client t) (directive numeral-directive))
+  '((:type integer :default 0)
+    (:type character :default #\Space)
+    (:type character :default #\,)
+    (:type integer :default 3)))
+
+(defmacro define-numeral-directive (client-class char pattern)
+  `(defmethod invistra:specialize-directive
+       ((client ,client-class) (char (eql ,char)) directive (end-directive t))
+     (change-class directive 'numeral-directive
+                   :pattern ',pattern)))
+
+#|(defmethod numeral-pattern ((name null))
+  '#1=(#("0" "1" "2" "3" "4" "5" "6" "7" "8" "9")
+        . #1#))
+
+(defmethod numeral-pattern ((name (eql #\O)))
+  '(#(nil "I" "II" "III" "IIII")
+    #("" "V")
+    #("" "X" "XX" "XXX" "XXXX")
+    #("" "L")
+    #("" "C" "CC" "CCC" "CCCC")
+    #("" "D")
+    #("" "M" "MM" "MMM" "MMMM")))
+
+(defmethod numeral-pattern ((name (eql #\R)))
+  '(#(nil "I" "II" "III" "IV" "V" "VI" "VII" "VIII" "IX")
+    #("" "X" "XX" "XXX" "XL" "L" "LX" "LXX" "LXXX" "XC")
+    #("" "C" "CC" "CCC" "CD" "D" "DC" "DCC" "DCCC" "CM")
+    #("" "M" "MM" "MMM" "MMMM")))
+
+(defmethod numeral-pattern ((name (eql #\E)))
+  '(#(nil "𐌠" "𐌠𐌠" "𐌠𐌠𐌠" "𐌠𐌠𐌠𐌠")
+    #("" "𐌡")
+    #("" "𐌢" "𐌢𐌢" "𐌢𐌢𐌢" "𐌢𐌢𐌢𐌢")
+    #("" "𐌣")
+    #("" "𐌟" "𐌟𐌟" "𐌟𐌟𐌟" "𐌟𐌟𐌟𐌟")))
+
+(defmethod numeral-pattern ((name (eql #\K)))
+  '#1=(#("𝋀" "𝋁" "𝋂" "𝋃" "𝋄"
+         "𝋅" "𝋆" "𝋇" "𝋈" "𝋉"
+         "𝋊" "𝋋" "𝋌" "𝋍" "𝋎"
+         "𝋏" "𝋐" "𝋑" "𝋒" "𝋓")
+        . #1#))|#
+
+(defun print-numeral-arg (client colon-p at-sign-p pattern mincol padchar commachar comma-interval)
+  (prog ((q (invistra:consume-next-argument t))
+         (r 0)
+         (c 0)
+         parts
+         (comma-part (string commachar))
+         result
+         pad-length
+         place)
+   repeat
+     (setq place (pop pattern))
+     (multiple-value-setq (q r)
+       (floor q (length place)))
+     (push (aref place r) parts)
+     (unless (zerop q)
+       (when colon-p
+         (setq c (mod (incf c) comma-interval))
+         (when (zerop c)
+           (push (string comma-part) parts)))
+       (go repeat))
+     (setf result (apply #'concatenate 'string parts)
+           pad-length (max 0 (- mincol (inravina:stream-measure-string invistra:*destination* result))))
+     (write-string result invistra:*destination*)))
+
+(defmethod invistra:interpret-item (client (directive numeral-directive) &optional parameters)
+  (apply #'print-numeral-arg client
+         (invistra:colon-p directive) (invistra:at-sign-p directive)
+         (numeral-pattern directive)
+         parameters))
+
+(defmethod invistra:compile-item (client (directive numeral-directive) &optional parameters)
+  `((print-numeral-arg ,(incless:client-form client)
+                       ,(invistra:colon-p directive) ,(invistra:at-sign-p directive)
+                       ,(numeral-pattern directive)
+                       ,@parameters)))
diff --git a/code/numeral/packages.lisp b/code/numeral/packages.lisp
new file mode 100644
index 0000000..64b308b
--- /dev/null
+++ b/code/numeral/packages.lisp
@@ -0,0 +1,3 @@
+(defpackage #:invistra-numeral
+  (:use #:cl)
+  (:export #:define-numeral-directive))
diff --git a/code/numeral/test/directive.lisp b/code/numeral/test/directive.lisp
new file mode 100644
index 0000000..4c6e24f
--- /dev/null
+++ b/code/numeral/test/directive.lisp
@@ -0,0 +1,16 @@
+(in-package #:invistra-numeral/test)
+
+(defclass numeral-client (incless-extrinsic:extrinsic-client) ())
+
+(defvar *kaktovik-numeral-pattern*
+  '#1=(#("𝋀" "𝋁" "𝋂" "𝋃" "𝋄"
+         "𝋅" "𝋆" "𝋇" "𝋈" "𝋉"
+         "𝋊" "𝋋" "𝋌" "𝋍" "𝋎"
+         "𝋏" "𝋐" "𝋑" "𝋒" "𝋓")
+        . #1#))
+
+(invistra-numeral:define-numeral-directive numeral-client #\K *kaktovik-numeral-pattern*)
+
+(defmacro my-formatter (control-string)
+  (let ((incless-extrinsic:*client* (make-instance 'numeral-client)))
+    (invistra:formatter incless-extrinsic:*client* control-string)))
diff --git a/code/numeral/test/packages.lisp b/code/numeral/test/packages.lisp
new file mode 100644
index 0000000..6eb4d22
--- /dev/null
+++ b/code/numeral/test/packages.lisp
@@ -0,0 +1,4 @@
+(cl:in-package #:common-lisp-user)
+
+(defpackage #:invistra-numeral/test
+  (:use #:cl #:parachute))
diff --git a/code/numeral/test/test.lisp b/code/numeral/test/test.lisp
new file mode 100644
index 0000000..65d43af
--- /dev/null
+++ b/code/numeral/test/test.lisp
@@ -0,0 +1,8 @@
+(in-package #:invistra-numeral/test)
+
+(define-test "kaktovik.01"
+  (let ((incless-extrinsic:*client* (make-instance 'numeral-client)))
+    (is equal
+        "𝋒𝋆𝋀"
+        (with-output-to-string (stream)
+          (funcall (my-formatter "~k") stream (+ (* 18 20 20) (* 6 20)))))))
diff --git a/invistra-numeral.asd b/invistra-numeral.asd
new file mode 100644
index 0000000..8da8425
--- /dev/null
+++ b/invistra-numeral.asd
@@ -0,0 +1,34 @@
+(cl:in-package #:asdf-user)
+
+(defsystem "invistra-numeral"
+  :description "Additional numeral printers for Invistra"
+  :license "BSD"
+  :author "Tarn W. Burton"
+  :maintainer "Tarn W. Burton"
+  :version (:read-file-form "version.sexp")
+  :homepage "https://github.com/s-expressionists/Invistra"
+  :bug-tracker "https://github.com/s-expressionists/Invistra/issues"
+  :depends-on ("invistra")
+  :components ((:module code
+                :pathname "code/numeral/"
+                :serial t
+                :components ((:file "packages")
+                             (:file "numeral")))))
+
+(defsystem "invistra-numeral/test"
+  :description "Tests for additional numeral printers for Invistra"
+  :license "BSD"
+  :author "Tarn W. Burton"
+  :maintainer "Tarn W. Burton"
+  :version (:read-file-form "version.sexp")
+  :homepage "https://github.com/s-expressionists/Invistra"
+  :bug-tracker "https://github.com/s-expressionists/Invistra/issues"
+  :depends-on ("invistra-extrinsic"
+               "invistra-numeral"
+               "parachute")
+  :components ((:module code
+                :pathname "code/numeral/test/"
+                :serial t
+                :components ((:file "packages")
+                             (:file "directive")
+                             (:file "test")))))