From 6550cfb68ab1443875054a69f60c9e474040d751 Mon Sep 17 00:00:00 2001
From: Jaidyn Ann <10477760+JadedCtrl@users.noreply.github.com>
Date: Fri, 30 Jun 2023 12:50:43 -0500
Subject: [PATCH] _Actually_ finish FIGlet support
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Now, text’ll be rendered with correct-ish smushing,
and fonts can be saved as Lisp source-code, just
like Tiled maps.
---
 figlet.lisp | 76 ++++++++++++++++++++++++++++++++++++++++++++++++-----
 1 file changed, 70 insertions(+), 6 deletions(-)

diff --git a/figlet.lisp b/figlet.lisp
index c9bd98b..b8b4765 100644
--- a/figlet.lisp
+++ b/figlet.lisp
@@ -17,6 +17,10 @@
 ;;;; A package for parsing Figlet fonts into simple associative lists, for
 ;;;; devious text-rendering purposes.
 
+(defpackage :figlet
+  (:export #:figlet-string #:figlet-font-plist #:save-font-to-file)
+  (:use cl))
+
 (in-package :figlet)
 
 
@@ -49,6 +53,50 @@ If no number is parsed out, return NIL."
   (str:unlines (remove-if-not #'stringp strings)))
 
 
+(defun count-in-a-row (item seq &key (count 0) (test #'eql) (from-end nil))
+  "How many times the given ITEM is found in SEQ in-a-row. Starts from the head
+of the list, unless FROM-END is specified. The TEST defaults to #'eql."
+  (if (> (length seq) 0)
+    (let* ((target-element (elt seq
+                                (if from-end (- (length seq) 1)
+                                    0)))
+           (remaining-seq (if from-end
+                              (subseq seq 0 (- (length seq) 1))
+                              (subseq seq 1))))
+      (if (apply test (list target-element item))
+          (count-in-a-row item remaining-seq
+                         :test test :from-end from-end
+                         :count (+ count 1))
+          count))
+    count))
+
+
+(defun most-in-a-row (item sequences &key (test #'eql) (from-end nil))
+  "Sort a sequence by the longest amount of the given ITEM In a row. Checks for
+reptitions of ITEM from the head of the list, unless FROM-END is specified."
+  (sort sequences (lambda (a b) (> (count-in-a-row item a :test test :from-end from-end)
+                                   (count-in-a-row item b :test test :from-end from-end)))))
+
+
+(defun least-in-a-row (item sequences &key (test #'eql) (from-end nil))
+  "Sort a sequence by the smallest amount of the given ITEM In a row. Checks for
+reptitions of ITEM from the head of the list, unless FROM-END is specified."
+  (reverse (most-in-a-row item sequences :test test :from-end from-end)))
+
+
+(defun equalize-padding (string)
+  "Equalize and minimize the padding between lines of a string."
+  (let* ((lines (str:lines string))
+         (least-padded-left (car (least-in-a-row #\space lines)))
+         (least-padded-right (car (least-in-a-row #\space lines :from-end 't)))
+         (left-padding (count-in-a-row #\space least-padded-left))
+         (right-padding (count-in-a-row #\space least-padded-right :from-end 't)))
+    (str:unlines
+     (mapcar (lambda (line)
+               (subseq line left-padding (- (length line) right-padding)))
+             (str:lines string)))))
+
+
 
 ;;; ———————————————————————————————————
 ;;; Font-parsing
@@ -62,7 +110,7 @@ associating a character with its respective string in the font-file.
            (sans-@ (string-trim "@" line)) ;; Lines are terminated by ‘@’
            (last-of-symbol-p (str:ends-with-p "@@" line)) ;; Character-art is terminated by ‘@@’
            (not-art-line-p (not (str:ends-with-p "@" line))) ;; If no @ at all, line’s a comment or header
-           (first-word-num (string->integer (car (str:words line)))) ;; If header line, this’ll be a character-code
+           (first-word-num (string->integer (car (str:words line)))) ;; If header line, this’ll be a charcode
            (current-art (ignore-errors (getf font-plist (code-char current-charcode)))))
       (cond
         ;; This is a header for a new char-art of specific char-code.
@@ -71,11 +119,16 @@ associating a character with its respective string in the font-file.
         ;; If a line of char-art, amass it!
         ((not not-art-line-p)
          (setf (getf font-plist (code-char current-charcode))
-               (unlines (list current-art
-                              (str:replace-all (getf font-plist :space-char) " " sans-@))))
-         (parse-lines (cdr lines) font-plist (if last-of-symbol-p
-                                                (+ current-charcode 1)
-                                                current-charcode)))
+               (unlines (list current-art sans-@)))
+         ;; We want to make sure unnecessary padding’s stripped!
+         (when last-of-symbol-p
+           (setf (getf font-plist (code-char current-charcode))
+                 (str:replace-all (getf font-plist :space-char) " "
+                                  (equalize-padding (unlines (list current-art sans-@))))))
+         (parse-lines (cdr lines) font-plist
+                      (if last-of-symbol-p
+                         (+ current-charcode 1)
+                         current-charcode)))
         ;; This is the first line of the file, the header line.
         ((str:starts-with-p "flf2a" line)
          (setf (getf font-plist :space-char)
@@ -118,3 +171,14 @@ with its respective string in the font-file.
         (str:unlines (mapcar (lambda (line-parts)
                                (reduce #'str:concat line-parts))
                              lines’-parts)))))
+
+
+
+;;; ———————————————————————————————————
+;;; Exporting
+;;; ———————————————————————————————————
+(defun save-font-to-file (path font-plist &optional (package ":FIGLET") (variable "*font*"))
+  "Given a parsed font plist, generate source-code that corresponds to it."
+  (with-open-file (file-stream path :direction :output :if-exists :supersede)
+    (format file-stream "(in-package ~A)~%(defparameter ~A~%  (QUOTE ~S))"
+            package variable font-plist)))