commit 51f5e862a3c7d8a8179b66fa5eb100a7ea69c862
Author: Dimitri Lozeve <dimitri@lozeve.com>
Date:   Sun Nov 21 22:13:35 2021 +0100

    Initial commit

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")))
+