From 51f5e862a3c7d8a8179b66fa5eb100a7ea69c862 Mon Sep 17 00:00:00 2001
From: Dimitri Lozeve <dimitri@lozeve.com>
Date: Sun, 21 Nov 2021 22:13:35 +0100
Subject: [PATCH] Initial commit

---
 .gitignore |   7 ++
 LICENSE    |  21 +++++
 README.org |  18 ++++
 colors.scm | 272 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 fancy.egg  |   5 +
 fancy.scm  |  35 +++++++
 format.scm |  93 ++++++++++++++++++
 rule.scm   |  16 ++++
 8 files changed, 467 insertions(+)
 create mode 100644 .gitignore
 create mode 100644 LICENSE
 create mode 100644 README.org
 create mode 100644 colors.scm
 create mode 100644 fancy.egg
 create mode 100644 fancy.scm
 create mode 100644 format.scm
 create mode 100644 rule.scm

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..586b0c7
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,7 @@
+*\~
+*.so
+*.link
+*.static.o
+*.import.scm
+*.build.sh
+*.install.sh
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..ed1d393
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,21 @@
+MIT License
+
+Copyright (c) 2021 Dimitri Lozeve
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
diff --git a/README.org b/README.org
new file mode 100644
index 0000000..e9e2ad9
--- /dev/null
+++ b/README.org
@@ -0,0 +1,18 @@
+* Fancy
+
+Fancy pretty-printing utilities for [[http://call-cc.org/][CHICKEN Scheme]].
+
+#+ATTR_HTML: :width 100% :style margin-left: auto; margin-right: auto;
+[[./demo.png]]
+
+** Features
+
+- [[https://en.wikipedia.org/wiki/ANSI_escape_code#CSI_(Control_Sequence_Introducer)_sequences][ANSI control codes]] for styling and cursor movement
+- Table formatting with [[https://unicode-table.com/en/blocks/box-drawing/][Unicode box drawing characters]]
+- Horizontal rules
+- Spinners
+
+** References
+
+- [[https://notes.burke.libbey.me/ansi-escape-codes/][Everything you never wanted to know about ANSI escape codes]]
+- [[https://github.com/willmcgugan/rich][Rich]] for Python, especially for their [[https://rich.readthedocs.io/en/latest/markup.html][console markup]] language
diff --git a/colors.scm b/colors.scm
new file mode 100644
index 0000000..637b140
--- /dev/null
+++ b/colors.scm
@@ -0,0 +1,272 @@
+(define +colors+
+  ;; Basic palette
+  '((black . "0")
+    (red . "1")
+    (green . "2")
+    (yellow . "3")
+    (blue . "4")
+    (magenta . "5")
+    (cyan . "6")
+    (white . "7")
+    ;; 256-color palette
+    (Black . "8;5;0")
+    (Maroon . "8;5;1")
+    (Green . "8;5;2")
+    (Olive . "8;5;3")
+    (Navy . "8;5;4")
+    (Purple . "8;5;5")
+    (Teal . "8;5;6")
+    (Silver . "8;5;7")
+    (Grey . "8;5;8")
+    (Red . "8;5;9")
+    (Lime . "8;5;10")
+    (Yellow . "8;5;11")
+    (Blue . "8;5;12")
+    (Fuchsia . "8;5;13")
+    (Aqua . "8;5;14")
+    (White . "8;5;15")
+    (Grey0 . "8;5;16")
+    (NavyBlue . "8;5;17")
+    (DarkBlue . "8;5;18")
+    (Blue3 . "8;5;19")
+    (Blue3 . "8;5;20")
+    (Blue1 . "8;5;21")
+    (DarkGreen . "8;5;22")
+    (DeepSkyBlue4 . "8;5;23")
+    (DeepSkyBlue4 . "8;5;24")
+    (DeepSkyBlue4 . "8;5;25")
+    (DodgerBlue3 . "8;5;26")
+    (DodgerBlue2 . "8;5;27")
+    (Green4 . "8;5;28")
+    (SpringGreen4 . "8;5;29")
+    (Turquoise4 . "8;5;30")
+    (DeepSkyBlue3 . "8;5;31")
+    (DeepSkyBlue3 . "8;5;32")
+    (DodgerBlue1 . "8;5;33")
+    (Green3 . "8;5;34")
+    (SpringGreen3 . "8;5;35")
+    (DarkCyan . "8;5;36")
+    (LightSeaGreen . "8;5;37")
+    (DeepSkyBlue2 . "8;5;38")
+    (DeepSkyBlue1 . "8;5;39")
+    (Green3 . "8;5;40")
+    (SpringGreen3 . "8;5;41")
+    (SpringGreen2 . "8;5;42")
+    (Cyan3 . "8;5;43")
+    (DarkTurquoise . "8;5;44")
+    (Turquoise2 . "8;5;45")
+    (Green1 . "8;5;46")
+    (SpringGreen2 . "8;5;47")
+    (SpringGreen1 . "8;5;48")
+    (MediumSpringGreen . "8;5;49")
+    (Cyan2 . "8;5;50")
+    (Cyan1 . "8;5;51")
+    (DarkRed . "8;5;52")
+    (DeepPink4 . "8;5;53")
+    (Purple4 . "8;5;54")
+    (Purple4 . "8;5;55")
+    (Purple3 . "8;5;56")
+    (BlueViolet . "8;5;57")
+    (Orange4 . "8;5;58")
+    (Grey37 . "8;5;59")
+    (MediumPurple4 . "8;5;60")
+    (SlateBlue3 . "8;5;61")
+    (SlateBlue3 . "8;5;62")
+    (RoyalBlue1 . "8;5;63")
+    (Chartreuse4 . "8;5;64")
+    (DarkSeaGreen4 . "8;5;65")
+    (PaleTurquoise4 . "8;5;66")
+    (SteelBlue . "8;5;67")
+    (SteelBlue3 . "8;5;68")
+    (CornflowerBlue . "8;5;69")
+    (Chartreuse3 . "8;5;70")
+    (DarkSeaGreen4 . "8;5;71")
+    (CadetBlue . "8;5;72")
+    (CadetBlue . "8;5;73")
+    (SkyBlue3 . "8;5;74")
+    (SteelBlue1 . "8;5;75")
+    (Chartreuse3 . "8;5;76")
+    (PaleGreen3 . "8;5;77")
+    (SeaGreen3 . "8;5;78")
+    (Aquamarine3 . "8;5;79")
+    (MediumTurquoise . "8;5;80")
+    (SteelBlue1 . "8;5;81")
+    (Chartreuse2 . "8;5;82")
+    (SeaGreen2 . "8;5;83")
+    (SeaGreen1 . "8;5;84")
+    (SeaGreen1 . "8;5;85")
+    (Aquamarine1 . "8;5;86")
+    (DarkSlateGray2 . "8;5;87")
+    (DarkRed . "8;5;88")
+    (DeepPink4 . "8;5;89")
+    (DarkMagenta . "8;5;90")
+    (DarkMagenta . "8;5;91")
+    (DarkViolet . "8;5;92")
+    (Purple . "8;5;93")
+    (Orange4 . "8;5;94")
+    (LightPink4 . "8;5;95")
+    (Plum4 . "8;5;96")
+    (MediumPurple3 . "8;5;97")
+    (MediumPurple3 . "8;5;98")
+    (SlateBlue1 . "8;5;99")
+    (Yellow4 . "8;5;100")
+    (Wheat4 . "8;5;101")
+    (Grey53 . "8;5;102")
+    (LightSlateGrey . "8;5;103")
+    (MediumPurple . "8;5;104")
+    (LightSlateBlue . "8;5;105")
+    (Yellow4 . "8;5;106")
+    (DarkOliveGreen3 . "8;5;107")
+    (DarkSeaGreen . "8;5;108")
+    (LightSkyBlue3 . "8;5;109")
+    (LightSkyBlue3 . "8;5;110")
+    (SkyBlue2 . "8;5;111")
+    (Chartreuse2 . "8;5;112")
+    (DarkOliveGreen3 . "8;5;113")
+    (PaleGreen3 . "8;5;114")
+    (DarkSeaGreen3 . "8;5;115")
+    (DarkSlateGray3 . "8;5;116")
+    (SkyBlue1 . "8;5;117")
+    (Chartreuse1 . "8;5;118")
+    (LightGreen . "8;5;119")
+    (LightGreen . "8;5;120")
+    (PaleGreen1 . "8;5;121")
+    (Aquamarine1 . "8;5;122")
+    (DarkSlateGray1 . "8;5;123")
+    (Red3 . "8;5;124")
+    (DeepPink4 . "8;5;125")
+    (MediumVioletRed . "8;5;126")
+    (Magenta3 . "8;5;127")
+    (DarkViolet . "8;5;128")
+    (Purple . "8;5;129")
+    (DarkOrange3 . "8;5;130")
+    (IndianRed . "8;5;131")
+    (HotPink3 . "8;5;132")
+    (MediumOrchid3 . "8;5;133")
+    (MediumOrchid . "8;5;134")
+    (MediumPurple2 . "8;5;135")
+    (DarkGoldenrod . "8;5;136")
+    (LightSalmon3 . "8;5;137")
+    (RosyBrown . "8;5;138")
+    (Grey63 . "8;5;139")
+    (MediumPurple2 . "8;5;140")
+    (MediumPurple1 . "8;5;141")
+    (Gold3 . "8;5;142")
+    (DarkKhaki . "8;5;143")
+    (NavajoWhite3 . "8;5;144")
+    (Grey69 . "8;5;145")
+    (LightSteelBlue3 . "8;5;146")
+    (LightSteelBlue . "8;5;147")
+    (Yellow3 . "8;5;148")
+    (DarkOliveGreen3 . "8;5;149")
+    (DarkSeaGreen3 . "8;5;150")
+    (DarkSeaGreen2 . "8;5;151")
+    (LightCyan3 . "8;5;152")
+    (LightSkyBlue1 . "8;5;153")
+    (GreenYellow . "8;5;154")
+    (DarkOliveGreen2 . "8;5;155")
+    (PaleGreen1 . "8;5;156")
+    (DarkSeaGreen2 . "8;5;157")
+    (DarkSeaGreen1 . "8;5;158")
+    (PaleTurquoise1 . "8;5;159")
+    (Red3 . "8;5;160")
+    (DeepPink3 . "8;5;161")
+    (DeepPink3 . "8;5;162")
+    (Magenta3 . "8;5;163")
+    (Magenta3 . "8;5;164")
+    (Magenta2 . "8;5;165")
+    (DarkOrange3 . "8;5;166")
+    (IndianRed . "8;5;167")
+    (HotPink3 . "8;5;168")
+    (HotPink2 . "8;5;169")
+    (Orchid . "8;5;170")
+    (MediumOrchid1 . "8;5;171")
+    (Orange3 . "8;5;172")
+    (LightSalmon3 . "8;5;173")
+    (LightPink3 . "8;5;174")
+    (Pink3 . "8;5;175")
+    (Plum3 . "8;5;176")
+    (Violet . "8;5;177")
+    (Gold3 . "8;5;178")
+    (LightGoldenrod3 . "8;5;179")
+    (Tan . "8;5;180")
+    (MistyRose3 . "8;5;181")
+    (Thistle3 . "8;5;182")
+    (Plum2 . "8;5;183")
+    (Yellow3 . "8;5;184")
+    (Khaki3 . "8;5;185")
+    (LightGoldenrod2 . "8;5;186")
+    (LightYellow3 . "8;5;187")
+    (Grey84 . "8;5;188")
+    (LightSteelBlue1 . "8;5;189")
+    (Yellow2 . "8;5;190")
+    (DarkOliveGreen1 . "8;5;191")
+    (DarkOliveGreen1 . "8;5;192")
+    (DarkSeaGreen1 . "8;5;193")
+    (Honeydew2 . "8;5;194")
+    (LightCyan1 . "8;5;195")
+    (Red1 . "8;5;196")
+    (DeepPink2 . "8;5;197")
+    (DeepPink1 . "8;5;198")
+    (DeepPink1 . "8;5;199")
+    (Magenta2 . "8;5;200")
+    (Magenta1 . "8;5;201")
+    (OrangeRed1 . "8;5;202")
+    (IndianRed1 . "8;5;203")
+    (IndianRed1 . "8;5;204")
+    (HotPink . "8;5;205")
+    (HotPink . "8;5;206")
+    (MediumOrchid1 . "8;5;207")
+    (DarkOrange . "8;5;208")
+    (Salmon1 . "8;5;209")
+    (LightCoral . "8;5;210")
+    (PaleVioletRed1 . "8;5;211")
+    (Orchid2 . "8;5;212")
+    (Orchid1 . "8;5;213")
+    (Orange1 . "8;5;214")
+    (SandyBrown . "8;5;215")
+    (LightSalmon1 . "8;5;216")
+    (LightPink1 . "8;5;217")
+    (Pink1 . "8;5;218")
+    (Plum1 . "8;5;219")
+    (Gold1 . "8;5;220")
+    (LightGoldenrod2 . "8;5;221")
+    (LightGoldenrod2 . "8;5;222")
+    (NavajoWhite1 . "8;5;223")
+    (MistyRose1 . "8;5;224")
+    (Thistle1 . "8;5;225")
+    (Yellow1 . "8;5;226")
+    (LightGoldenrod1 . "8;5;227")
+    (Khaki1 . "8;5;228")
+    (Wheat1 . "8;5;229")
+    (Cornsilk1 . "8;5;230")
+    (Grey100 . "8;5;231")
+    (Grey3 . "8;5;232")
+    (Grey7 . "8;5;233")
+    (Grey11 . "8;5;234")
+    (Grey15 . "8;5;235")
+    (Grey19 . "8;5;236")
+    (Grey23 . "8;5;237")
+    (Grey27 . "8;5;238")
+    (Grey30 . "8;5;239")
+    (Grey35 . "8;5;240")
+    (Grey39 . "8;5;241")
+    (Grey42 . "8;5;242")
+    (Grey46 . "8;5;243")
+    (Grey50 . "8;5;244")
+    (Grey54 . "8;5;245")
+    (Grey58 . "8;5;246")
+    (Grey62 . "8;5;247")
+    (Grey66 . "8;5;248")
+    (Grey70 . "8;5;249")
+    (Grey74 . "8;5;250")
+    (Grey78 . "8;5;251")
+    (Grey82 . "8;5;252")
+    (Grey85 . "8;5;253")
+    (Grey89 . "8;5;254")
+    (Grey93 . "8;5;255")))
+
+(define +bg-colors+
+  (map (lambda (c) `(,(string->symbol (string-append "on-" (symbol->string (car c))))
+		     . ,(cdr c)))
+       +colors+))
diff --git a/fancy.egg b/fancy.egg
new file mode 100644
index 0000000..4d18c35
--- /dev/null
+++ b/fancy.egg
@@ -0,0 +1,5 @@
+((author "Dimitri Lozeve")
+ (synopsis "Fancy pretty-printing utilities for CHICKEN Scheme")
+ (license "MIT")
+ (dependencies srfi-1 utf8 srfi-152)
+ (components (extension fancy)))
diff --git a/fancy.scm b/fancy.scm
new file mode 100644
index 0000000..3918376
--- /dev/null
+++ b/fancy.scm
@@ -0,0 +1,35 @@
+(module fancy
+(cursor-up
+ cursor-down
+ cursor-forward
+ cursor-back
+ cursor-next
+ cursor-previous
+ cursor-hor
+ cursor-pos
+ erase-in-display
+ erase-in-line
+ scroll-up
+ scroll-down
+ save-pos
+ restore-pos
+ graphics-rendition-code
+ graphics-style
+ parse-tag
+ parse-markup
+ remove-markup
+ rule)
+
+(import scheme
+	(chicken base)
+	(chicken format)
+	(chicken irregex)
+	srfi-1
+	utf8
+	srfi-152)
+
+(include "colors.scm")
+(include "format.scm")
+(include "rule.scm")
+
+)
diff --git a/format.scm b/format.scm
new file mode 100644
index 0000000..f9d89be
--- /dev/null
+++ b/format.scm
@@ -0,0 +1,93 @@
+;; ========================= Constants =========================
+
+(define +CSI+ "\033[")
+
+(define +basic-colors+
+  '((black . 0)
+    (red . 1)
+    (green . 2)
+    (yellow . 3)
+    (blue . 4)
+    (magenta . 5)
+    (cyan . 6)
+    (white . 7)))
+
+(define +basic-bg-colors+
+  '((on-black . 0)
+    (on-red . 1)
+    (on-green . 2)
+    (on-yellow . 3)
+    (on-blue . 4)
+    (on-magenta . 5)
+    (on-cyan . 6)
+    (on-white . 7)))
+
+(define +re-tags+ (irregex "\\[(/?[a-z ]*?)\\]"))
+
+
+;; ========================= Control sequences =========================
+
+(define (cursor-up #!optional (n 1)) (format "~a~aA" +CSI+ n))
+(define (cursor-down #!optional (n 1)) (format "~a~aB" +CSI+ n))
+(define (cursor-forward #!optional (n 1)) (format "~a~aC" +CSI+ n))
+(define (cursor-back #!optional (n 1)) (format "~a~aD" +CSI+ n))
+(define (cursor-next #!optional (n 1)) (format "~a~aE" +CSI+ n))
+(define (cursor-previous #!optional (n 1)) (format "~a~aF" +CSI+ n))
+(define (cursor-hor #!optional (n 1)) (format "~a~aG" +CSI+ n))
+(define (cursor-pos #!optional (n 1) (m 1)) (format "~a~a;~aH" +CSI+ n m))
+(define (erase-in-display #!optional (n 0)) (format "~a~aJ" +CSI+ n))
+(define (erase-in-line #!optional (n 0)) (format "~a~aK" +CSI+ n))
+(define (scroll-up #!optional (n 1)) (format "~a~aS" +CSI+ n))
+(define (scroll-down #!optional (n 1)) (format "~a~aT" +CSI+ n))
+(define (save-pos) (format "~as" +CSI+))
+(define (restore-pos) (format "~au" +CSI+))
+
+
+;; ========================= Graphics rendition parameters =========================
+
+(define (graphics-rendition-code tag)
+  (define basic-color (assoc tag +basic-colors+))
+  (define basic-bg-color (assoc tag +basic-bg-colors+))
+  (cond
+   ((eq? tag 'bold) "2")
+   ((eq? tag 'italic) "3")
+   ((eq? tag 'underline) "4")
+   (basic-color (format "3~a" (cdr basic-color)))
+   (basic-bg-color (format "4~a" (cdr basic-bg-color)))))
+
+(define (graphics-style #!optional (style '()))
+  (define colors (lset-intersection eq? style (map car +basic-colors+)))
+  (define bg-colors (lset-intersection eq? style (map car +basic-bg-colors+)))
+  (define style-without-colors (lset-difference eq? style
+						(map car +basic-colors+)
+						(map car +basic-bg-colors+)))
+  (define final-style (cons* (unless (null? colors) (car colors))
+			     (unless (null? bg-colors) (car bg-colors))
+			     style-without-colors))
+  (format "~a~am" +CSI+
+	  (string-join (filter string? (map graphics-rendition-code final-style)) ";")))
+
+
+;; ========================= Console markup =========================
+
+(define (parse-tag contents #!optional (style '()))
+  (define closing (eq? #\/ (string-ref contents 0)))
+  (define clean-contents (if closing (string-drop contents 1) contents))
+  (define clean-contents (irregex-replace/all "on " clean-contents "on-"))
+  (define tags (map string->symbol (string-split clean-contents " ")))
+  (define new-style (if closing
+			(lset-difference eq? style tags)
+			(lset-union eq? style tags)))
+  (define control-seq (graphics-style new-style))
+  (values control-seq new-style))
+
+(define (parse-markup text #!optional (style '()))
+  (define match (irregex-search +re-tags+ text))
+  (if match
+      (let-values (((control-seq new-style) (parse-tag (irregex-match-substring match 1) style)))
+	(parse-markup (irregex-replace +re-tags+ text control-seq) new-style))
+      (string-join (list text (graphics-style '())))))
+
+(define (remove-markup text)
+  (irregex-replace/all +re-tags+ text ""))
+
diff --git a/rule.scm b/rule.scm
new file mode 100644
index 0000000..48a7c31
--- /dev/null
+++ b/rule.scm
@@ -0,0 +1,16 @@
+(define (rule text #!key (width 80) (style 'simple))
+  (define rule-len (- width (+ 2 (string-length (remove-markup text)))))
+  (define left-len (sub1 (quotient rule-len 2)))
+  (define right-len (sub1 (+ (remainder rule-len 2) (quotient rule-len 2))))
+  (define c (cond
+	     ((eq? style 'simple) #\━)
+	     ((eq? style 'double) #\═)
+	     ((eq? style 'dashed) #\╌)))
+  (string-join
+   (list (make-string left-len c)
+	 " "
+	 (parse-markup text)
+	 " "
+	 (make-string right-len c)
+	 "\n")))
+