Initial commit

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