(uiop:define-package :sloppy-text/impl
(:export #:keeppenning #:list-of-lines #:phlog #:lines)
(:nicknames :sloppy-text))
#|
scroll to the bottom of the file
|#
(in-package :sloppy-text)
(defun fill-line (&optional (width 100) &key (default-char #\space))
(with-output-to-string (*standard-output*)
(loop repeat width do (princ default-char))))
(defun list-of-lines (&optional (no 30) &rest for-fill-line) "
The emacs paper says a list of line-strings is appropriate
"
(loop repeat no collect (apply #'fill-line for-fill-line)))
(defun princ-lines (lines &optional (stream t))
(format stream "~{~a~^~%~}" lines))
(defun random-graphic-char () "
does what it sounds like.
"
(let ((chars `(,@(loop for n below 128 for ch = (code-char n)
for gp = (graphic-char-p ch)
when gp collect ch))))
(nth (random (length chars)) chars)))
(defun boundarise-linep (line x-offset
&key (default-char #\space)
(fun-boundary-char #'random-graphic-char)) "
generalised boolean: Is there a collision coming left to x-offset?
Returns the line with a modified 'line' character
or else nil.
fun-boundary-char should be a function with no formals that returns
a single character.
"
(loop for x below (1+ x-offset)
unless (char= (char line x) default-char) do
(return-from boundarise-linep nil))
(setf (char line x-offset) (funcall fun-boundary-char))
(values line))
(defun boundarise (list x-off y-offset phase
&rest
boundarise-linep-args
&aux
(new-list
(mapcar (lambda (x) (format nil "~a" x))
(nthcdr y-offset list)))) "
list is a list of lines as from list-of-lines
x-off and y-offset top left beginning of trace
phase like #c(5 1) (5 across for 1 down)
boundarise-linep-args suitable for boundarise-linep
"
(loop for line in new-list for n from 0
for x-offset = x-off then (if (zerop (mod n (imagpart phase)))
(+ x-offset (realpart phase))
x-offset)
for new-line = (apply #'boundarise-linep
(format nil "~a" line)
(min x-offset (1- (length line)))
boundarise-linep-args)
while (< (1+ x-offset) (length line))
unless new-line do (return-from boundarise nil)
collect new-line
into final-lines
finally (return final-lines)))
(defun add-boundaryp (line-list phase x-off y-off &rest linep-args) "
traces a line on a new copy of line-list:
phase is like #c(5 1) to mean 5 spaces across for every 1 line down
x-off and y-off top left extremum of line
linep-args suitable for boundarise
"
(loop for n from y-off to (1- (length line-list))
for new-lines = (apply #'boundarise line-list x-off n phase linep-args)
for mid-lines = (append (subseq line-list 0 n)
new-lines)
for all-lines = (append mid-lines
(last line-list
(- (length line-list)
(length mid-lines))))
when new-lines return all-lines))
(defun stuff-strings (things line-list &key (default-char #\space)
&aux (strings (mapcar (lambda (x)
(format nil "~a" x))
things))) "
Listen, it's not my greatest work. I've been sick, and it was after midnight
(and yet also before midnight, thank-you rat, ams and kmp)
ARGS: things - a list suitable for mapcar. elements will be aesthetically
printed.
line-list - as from sloppy-text/impl::list-of-lines
:default-char - optional, what is considered an unoccupied char.
Attempts to write words that were things into each subsequent line in lines
if there's space: Writes them touching whatever they're next to.
Returns a (list remaining-words modified-lines-list)
suitable for
(apply #'stuff-strings #c(5 1) *)
"
(loop for line in line-list for n from 0
for string = (pop strings)
then (cond ((null string) (pop strings))
(t string))
for blocked-idx = (search (format nil "~a" default-char)
line
:test-not 'char=)
while string
nconc (and blocked-idx
(if (< (length string) (1+ blocked-idx))
(let* ((new-string
(concatenate 'string
string
(subseq
line
blocked-idx)))
(len-new (length new-string))
(dif (- (length line) (length new-string))))
(prog1
`(,(concatenate 'string
(subseq line 0 dif)
new-string))
(setf string nil)))
(list line)))
into results
finally (return (list (if string (push string strings)
strings)
results))))
(defun keeppenning (phase words lines) "
Args:
phase - an integral complex number. #c(5 1)
means for every 1 line down, go five
more spaces indented.
words - A list suitable for mapcar. What is
used will be the aesthetic print of
w/e you put in the list.
lines - A list of string \" lines \"
which could have content already.
default-char seen elsewhere is left as its default,
space for now.
RETURNS:
new-lines : freshly consed modified versions
of lines, to contain words to the
extent they fit.
See the example at the bottom of impl.lisp
"
(loop
for old-words = (copy-list words)
for new-lines = (add-boundaryp lines phase 0 0)
for offset = (or (loop for n from 0
for l in lines for k in new-lines
when (not (string= l k)) return n)
0)
for results = (stuff-strings words (subseq new-lines offset))
for nex-lines = (cadr results)
for new-len = (length new-lines)
for nex-len = (length nex-lines)
for lin-len = (length lines)
for joined-lines =
(append (copy-list (subseq lines 0 offset))
(copy-list nex-lines)
(copy-list (subseq lines
(+ offset
nex-len))))
when joined-lines do
(setf lines joined-lines
words (car results))
while (not (equal words old-words))
finally (return joined-lines)))
(defvar *phlog*
'(Well i cannot say it went perfectly but after seeing jns
create art with the words of the epic freebsd driver phlog
i decided i would give some notion of phlogging on an angle
a go |.| as well as |art,| hopefully we can resist being
included in LLM |data.| even though what i have done here
is loosely the same as transposing a block of text i think
its kind of loose hanging enough it would be hard for an
insufficiently loose robot to |catch.|))
(defvar *lines*
(list-of-lines 30 50))
#| ;;; e
SLOPPY-TEXT/IMPL> (asdf:load-system :sloppy-text)
SLOPPY-TEXT/IMPL> (use-package :sloppy-text)
SLOPPY-TEXT/IMPL> (keeppenning #c(5 1) *phlog* *lines*)
("3 "
" WELL8 "
"8 IK "
" [ CANNOTm "
" SEEING1 SAY5 "
" THEa JNS? IT8 "
"J EPIC% CREATEN WENT, "
" GIVE3 FREEBSDt ART6PERFECTLYM "
"r SOME& DRIVER` WITH, BUTF "
" GO< NOTION\\ PHLOG@ THEA AFTERB "
" .. OFs IO WORDSA "
" A ASZPHLOGGINGl DECIDED& OFX "
"P RESIST1 WELLZ ONJ I' "
" WHAT< BEING+ AS7 ANm WOULDu "
"| IR INCLUDEDU art,% ANGLEJ "
" AS< HAVE} INgHOPEFULLYk A] "
" ( DONEn LLM\" WEK "
"' TRANSPOSING) HERE7 data.; CAN= "
" ITSR AJ ISq EVENE "
"s KIND3 BLOCKq LOOSELYc THOUGH, "
" HARDH OFp OFx THE4 "
" FORq LOOSEk TEXTI SAME3 "
" ANN HANGINGN I) "
" INSUFFICIENTLYU ENOUGHq THINKN "
" LOOSEp IT` "
" ROBOTw WOULD( "
" TON BEm "
" catch.Q "
" "
" ")
|#