None of the original commit messages would actually help anyone
This commit is contained in:
Logan Hunt
commit
3db9a2eb7a
2
.gitignore
vendored
Normal file
2
.gitignore
vendored
Normal file
@ -0,0 +1,2 @@
|
|||||||
|
*.db
|
||||||
|
*.env
|
||||||
10
README.org
Normal file
10
README.org
Normal file
@ -0,0 +1,10 @@
|
|||||||
|
* SBCL Speedrun Timer
|
||||||
|
This is a complete rewrite of my first Lisp project: a speedrun timer. It uses ncurses and a SQLite database, with the [[https://github.com/fukamachi/mito][MITO ORM.]]
|
||||||
|
** Requirements
|
||||||
|
+ [[https://www.quicklisp.org/beta/][Quicklisp]]
|
||||||
|
+ [[http://www.sbcl.org/platform-table.html][SBCL]]
|
||||||
|
** Usage
|
||||||
|
*** Importing categories
|
||||||
|
Config files are documented by the examples in ~configs~. Once a config file is written, import that category and its splits by running ~sbcl --load main.lisp -i <path-to-config>~. This will add the category and its splits to the timer's SQLite database.
|
||||||
|
*** Running
|
||||||
|
Simply ~sbcl --load main.lisp~
|
||||||
14
categories/supermetroid-any-kpdr.conf
Normal file
14
categories/supermetroid-any-kpdr.conf
Normal file
@ -0,0 +1,14 @@
|
|||||||
|
[category]
|
||||||
|
:name Super Metroid
|
||||||
|
:percentage KPDR Any%
|
||||||
|
|
||||||
|
[splits]
|
||||||
|
:name Boomba
|
||||||
|
:name Kraid McGraid
|
||||||
|
:name Wave Beam
|
||||||
|
:name Phantoon
|
||||||
|
:name Botwoon
|
||||||
|
:name Draygon
|
||||||
|
:name Lower Norfair
|
||||||
|
:name Ridley
|
||||||
|
:name See You Next Mission!
|
||||||
85
config.lisp
Normal file
85
config.lisp
Normal file
@ -0,0 +1,85 @@
|
|||||||
|
;; Read a file into a list of lines, trimming whitespace and returning
|
||||||
|
;; only non-empty lines
|
||||||
|
(defun read-lines (path)
|
||||||
|
(remove-if
|
||||||
|
(lambda (s) (equal "" s))
|
||||||
|
(mapcar (lambda (s) (string-trim '(#\Space #\Newline #\Tab) s))
|
||||||
|
(with-open-file (stream path)
|
||||||
|
(loop for line = (read-line stream nil)
|
||||||
|
while line
|
||||||
|
collect line)))))
|
||||||
|
|
||||||
|
;; Returns a list of sections with [name] as first element and all
|
||||||
|
;; lines of the section as the second containing properties and
|
||||||
|
;; specs, skipping trailing and preceding whitespace and empty lines
|
||||||
|
(defun sections (lines &optional (section-list '()) (current-section "") (current-section-list '()))
|
||||||
|
(if (not lines)
|
||||||
|
(cond
|
||||||
|
((> (length current-section) 0)
|
||||||
|
(cons (list current-section current-section-list) section-list))
|
||||||
|
(t section-list))
|
||||||
|
(let* ((line (car lines))
|
||||||
|
(linelen (length line)))
|
||||||
|
(cond
|
||||||
|
((= linelen 0)
|
||||||
|
(sections (cdr lines) section-list current-section current-section-list))
|
||||||
|
((and (equal #\[ (char line 0)) (equal #\] (char line (1- linelen))))
|
||||||
|
(sections (cdr lines) (unless (= (length current-section) 0)
|
||||||
|
(cons (list current-section current-section-list) section-list))
|
||||||
|
(subseq line 1 (1- linelen))))
|
||||||
|
(t
|
||||||
|
(sections (cdr lines) section-list current-section (append current-section-list (list line))))))))
|
||||||
|
|
||||||
|
;; Get an ordered list of properties associated with [name] of a section
|
||||||
|
(defun get-section (section-name sections)
|
||||||
|
(if (not sections)
|
||||||
|
nil
|
||||||
|
(let* ((section (car sections))
|
||||||
|
(current-section-name (car section))
|
||||||
|
(props (cadr section)))
|
||||||
|
(if (equal current-section-name section-name)
|
||||||
|
props
|
||||||
|
(get-section section-name (cdr sections))))))
|
||||||
|
|
||||||
|
;; Go line by line in section until first element is property
|
||||||
|
(defun get-property (properties property)
|
||||||
|
(if (not properties)
|
||||||
|
nil
|
||||||
|
(let* ((prop-s (car properties))
|
||||||
|
(name-val (cl-ppcre:register-groups-bind (prop-name val)
|
||||||
|
("^:(\\w*) (.*)$" prop-s)
|
||||||
|
(list prop-name val)))
|
||||||
|
(name (car name-val))
|
||||||
|
(val (cadr name-val)))
|
||||||
|
(if (equal property name)
|
||||||
|
val
|
||||||
|
(get-property (cdr properties) property)))))
|
||||||
|
|
||||||
|
;; Creates the category object from [category] section
|
||||||
|
(defun create-category-object (category-section)
|
||||||
|
(make-instance 'category
|
||||||
|
:name (get-property category-section "name")
|
||||||
|
:percentage (get-property category-section "percentage")))
|
||||||
|
|
||||||
|
|
||||||
|
;; Creates the splits
|
||||||
|
(defun create-category-split-objects (category splits-section &optional (splits '()))
|
||||||
|
(if (not splits-section)
|
||||||
|
splits
|
||||||
|
(create-category-split-objects
|
||||||
|
category
|
||||||
|
(cdr splits-section)
|
||||||
|
(append
|
||||||
|
splits
|
||||||
|
(list (make-instance 'category-split
|
||||||
|
:name (get-property splits-section "name")
|
||||||
|
:category category))))))
|
||||||
|
|
||||||
|
;; Driver that takes the config and inserts the category and its
|
||||||
|
;; splits into the db, obviously requires a mito toplevel connection
|
||||||
|
(defun import-config (file-path)
|
||||||
|
(let*
|
||||||
|
((config-sections (sections (read-lines file-path)))
|
||||||
|
(category (mito:insert-dao (create-category-object (get-section "category" config-sections))))
|
||||||
|
(splits (mapcar 'mito:insert-dao (create-category-split-objects category (get-section "splits" config-sections)))))
|
||||||
|
(list category splits)))
|
||||||
19
database/category.lisp
Normal file
19
database/category.lisp
Normal file
@ -0,0 +1,19 @@
|
|||||||
|
(mito:deftable category ()
|
||||||
|
((name :col-type (:varchar 128))
|
||||||
|
(percentage :col-type (:varchar 128)))
|
||||||
|
(:record-timestamps nil)
|
||||||
|
(:conc-name category-))
|
||||||
|
|
||||||
|
(mito:deftable category-split ()
|
||||||
|
((name :col-type (:varchar 128))
|
||||||
|
(category :col-type category))
|
||||||
|
(:record-timestamps nil)
|
||||||
|
(:conc-name category-split-))
|
||||||
|
|
||||||
|
(defun category-splits (category)
|
||||||
|
(mito:select-dao 'category-split
|
||||||
|
(sxql:where (:= :category category))
|
||||||
|
;; Assumption that split categories are entered in the correct order by id
|
||||||
|
(sxql:order-by :id)))
|
||||||
|
|
||||||
|
;; select *, sum(julianday(end_time)-julianday(start_time))*24*60*60 as total_time from run_split group by run_id order by total_time;
|
||||||
17
database/run.lisp
Normal file
17
database/run.lisp
Normal file
@ -0,0 +1,17 @@
|
|||||||
|
(mito:deftable run ()
|
||||||
|
((category :col-type category))
|
||||||
|
(:record-timestamps nil)
|
||||||
|
(:conc-name run-))
|
||||||
|
|
||||||
|
(mito:deftable run-split ()
|
||||||
|
((run :col-type run)
|
||||||
|
(category-split :col-type category-split)
|
||||||
|
(start-time :col-type (or :datetime :null))
|
||||||
|
(end-time :col-type (or :datetime :null)))
|
||||||
|
(:record-timestamps nil)
|
||||||
|
(:conc-name run-split-))
|
||||||
|
|
||||||
|
(defun run-splits (run)
|
||||||
|
(mito:select-dao 'run-split
|
||||||
|
(sxql:order-by :category_split_id)
|
||||||
|
(sxql:where (:= :run run))))
|
||||||
8
database/seeds.lisp
Normal file
8
database/seeds.lisp
Normal file
@ -0,0 +1,8 @@
|
|||||||
|
(mito:create-dao 'category :name "Super Metroid" :percentage "Any%"))
|
||||||
|
|
||||||
|
(mito:create-dao 'category :name "Portal 1" :percentage "Any%"))
|
||||||
|
|
||||||
|
(mito:create-dao 'category :name "Super Mario 64" :percentage "16 Stars"))
|
||||||
|
|
||||||
|
(mito:create-dao 'category :name "Minecraft" :percentage "Any% RSG"))
|
||||||
|
(mito:create-dao 'category :name "Minecraft" :percentage "Any% SSG"))
|
||||||
62
digits.lisp
Normal file
62
digits.lisp
Normal file
@ -0,0 +1,62 @@
|
|||||||
|
(defparameter *big-digits* (make-hash-table :test 'equal))
|
||||||
|
(mapcar (lambda (x) (setf (gethash (car x) *big-digits*) (cadr x)))
|
||||||
|
'((#\0 (" ___ "
|
||||||
|
" / _ \\ "
|
||||||
|
"| | | |"
|
||||||
|
"| |_| |"
|
||||||
|
" \\___/ "))
|
||||||
|
(#\1 (" _ "
|
||||||
|
"/ |"
|
||||||
|
"| |"
|
||||||
|
"| |"
|
||||||
|
"|_|"))
|
||||||
|
(#\2 (" ____ "
|
||||||
|
"|___ \\ "
|
||||||
|
" __) |"
|
||||||
|
" / __/ "
|
||||||
|
"|_____|"))
|
||||||
|
(#\3 (" _____ "
|
||||||
|
"|___ / "
|
||||||
|
" |_ \\ "
|
||||||
|
" ___) |"
|
||||||
|
"|____/ "))
|
||||||
|
(#\4 (" _ _ "
|
||||||
|
"| || | "
|
||||||
|
"| || |_ "
|
||||||
|
"|__ _|"
|
||||||
|
" |_| "))
|
||||||
|
(#\5 (" ____ "
|
||||||
|
"| ___| "
|
||||||
|
"|___ \\ "
|
||||||
|
" ___) |"
|
||||||
|
"|____/ "))
|
||||||
|
(#\6 (" __ "
|
||||||
|
" / /_ "
|
||||||
|
"| '_ \\ "
|
||||||
|
"| (_) |"
|
||||||
|
" \\___/ "))
|
||||||
|
(#\7 (" _____ "
|
||||||
|
"|___ |"
|
||||||
|
" / / "
|
||||||
|
" / / "
|
||||||
|
" /_/ "))
|
||||||
|
(#\8 (" ___ "
|
||||||
|
" ( _ ) "
|
||||||
|
" / _ \\ "
|
||||||
|
"| (_) |"
|
||||||
|
" \\___/ "))
|
||||||
|
(#\9 (" ___ "
|
||||||
|
" / _ \\ "
|
||||||
|
"| (_) |"
|
||||||
|
" \\__, |"
|
||||||
|
" /_/ "))
|
||||||
|
(#\. (" "
|
||||||
|
" "
|
||||||
|
" "
|
||||||
|
" _ "
|
||||||
|
"(_)"))
|
||||||
|
(#\: (" _ "
|
||||||
|
"(_)"
|
||||||
|
" "
|
||||||
|
" _ "
|
||||||
|
"(_)"))))
|
||||||
39
main.lisp
Normal file
39
main.lisp
Normal file
@ -0,0 +1,39 @@
|
|||||||
|
(ql:quickload '(unix-opts mito cl-ppcre croatoan local-time))
|
||||||
|
|
||||||
|
;; Migrate database structure
|
||||||
|
(mito:connect-toplevel :sqlite3 :database-name #P"timer.db")
|
||||||
|
(setq mito:*auto-migration-mode* t)
|
||||||
|
(load "database/category.lisp")
|
||||||
|
(load "database/run.lisp")
|
||||||
|
|
||||||
|
;; Utils
|
||||||
|
(load "util.lisp")
|
||||||
|
|
||||||
|
;; Config file importing
|
||||||
|
(load "config.lisp")
|
||||||
|
|
||||||
|
;; Load the UI
|
||||||
|
(load "ui.lisp")
|
||||||
|
|
||||||
|
;; The timing logic
|
||||||
|
(load "speedrun.lisp")
|
||||||
|
|
||||||
|
;; Define command line arguments
|
||||||
|
(opts:define-opts
|
||||||
|
(:name :import
|
||||||
|
:description "create splits and category from a config file"
|
||||||
|
:short #\i
|
||||||
|
:long "import"
|
||||||
|
:arg-parser #'identity))
|
||||||
|
|
||||||
|
(defmacro when-option ((options opt) &body body)
|
||||||
|
`(let ((it (getf ,options ,opt)))
|
||||||
|
(when it
|
||||||
|
,@body)))
|
||||||
|
(defun main ()
|
||||||
|
(let ((options (opts:get-opts)))
|
||||||
|
(when-option (options :import)
|
||||||
|
(import-config (getf options :import))))
|
||||||
|
(run-ui))
|
||||||
|
|
||||||
|
(main)
|
||||||
67
speedrun.lisp
Normal file
67
speedrun.lisp
Normal file
@ -0,0 +1,67 @@
|
|||||||
|
(defclass speedrun ()
|
||||||
|
((state
|
||||||
|
;; RUNNING, STOPPED
|
||||||
|
:initarg :state
|
||||||
|
:accessor speedrun-state)
|
||||||
|
(title
|
||||||
|
:initarg :title
|
||||||
|
:accessor speedrun-title)
|
||||||
|
;; Whatever internal time units decided by SBCL (get-internal-real-time)
|
||||||
|
;; (local-time:now) *could* be used, but by my testing it's around 6 times slower
|
||||||
|
;; so why not
|
||||||
|
(start-timestamp
|
||||||
|
:initarg :start-timestamp
|
||||||
|
:accessor speedrun-start-timestamp)
|
||||||
|
(elapsed ;; milliseconds
|
||||||
|
:initarg :elapsed
|
||||||
|
:accessor speedrun-elapsed)
|
||||||
|
(splits
|
||||||
|
:initarg :splits
|
||||||
|
:accessor speedrun-splits)
|
||||||
|
(run-dao
|
||||||
|
:initarg :run-dao
|
||||||
|
:accessor speedrun-run-dao)
|
||||||
|
(current-split-index
|
||||||
|
:initarg :current-split-index
|
||||||
|
:accessor speedrun-current-split-index)))
|
||||||
|
|
||||||
|
(defun make-speedrun (category)
|
||||||
|
(let* ((run (make-instance 'run :category category))
|
||||||
|
(splits (mapcar (lambda (category-split)
|
||||||
|
(make-instance 'run-split :category-split category-split :run run))
|
||||||
|
(category-splits category))))
|
||||||
|
(make-instance 'speedrun
|
||||||
|
:state 'STOPPED
|
||||||
|
:title (category-name category)
|
||||||
|
:splits splits
|
||||||
|
:current-split-index 0
|
||||||
|
:elapsed 0.0
|
||||||
|
:run-dao run)))
|
||||||
|
|
||||||
|
(defun current-split (speedrun)
|
||||||
|
(nth (speedrun-current-split-index speedrun) (speedrun-splits speedrun)))
|
||||||
|
|
||||||
|
;; Updates the current total elapsed time of the speedrun if it's running
|
||||||
|
(defun update-time (speedrun)
|
||||||
|
(if (eq (speedrun-state speedrun) 'RUNNING)
|
||||||
|
(setf (speedrun-elapsed speedrun) (* 1000 (/ (- (get-internal-real-time) (speedrun-start-timestamp speedrun)) internal-time-units-per-second)))))
|
||||||
|
|
||||||
|
;; Initializes a speedrun to start running the timer
|
||||||
|
(defun start-speedrun (speedrun)
|
||||||
|
(setf (speedrun-state speedrun) 'RUNNING
|
||||||
|
(speedrun-start-timestamp speedrun) (get-internal-real-time)
|
||||||
|
(run-split-start-time (current-split speedrun)) (local-time:now)))
|
||||||
|
|
||||||
|
;; Set the state of the speedrun to be stopped if there are no more
|
||||||
|
;; splits, or set the current split to the next one
|
||||||
|
(defun next-split (speedrun)
|
||||||
|
(let ((now (local-time:now)))
|
||||||
|
(setf (run-split-end-time (current-split speedrun)) now)
|
||||||
|
(inc (speedrun-current-split-index speedrun))
|
||||||
|
(if (equal (speedrun-current-split-index speedrun) (length (speedrun-splits speedrun)))
|
||||||
|
(setf (speedrun-state speedrun) 'STOPPED)
|
||||||
|
(setf (run-split-start-time (current-split speedrun)) now))))
|
||||||
|
|
||||||
|
;; Saves the speedrun into the database
|
||||||
|
(defun save-speedrun (speedrun)
|
||||||
|
(mapcar #'mito:save-dao (cons (speedrun-run-dao speedrun) (speedrun-splits speedrun))))
|
||||||
113
ui.lisp
Normal file
113
ui.lisp
Normal file
@ -0,0 +1,113 @@
|
|||||||
|
(defparameter *lispruns-logo*
|
||||||
|
'("db d888888b .d8888. d8888b. d8888b. db db d8b db .d8888."
|
||||||
|
"88 `88' 88' YP 88 `8D 88 `8D 88 88 888o 88 88' YP"
|
||||||
|
"88 88 `8bo. 88oodD' 88oobY' 88 88 88V8o 88 `8bo. "
|
||||||
|
"88 88 `Y8b. 88~~~ 88`8b 88 88 88 V8o88 `Y8b."
|
||||||
|
"88booo. .88. db 8D 88 88 `88. 88b d88 88 V888 db 8D"
|
||||||
|
"Y88888P Y888888P `8888Y' 88 88 YD ~Y8888P' VP V8P `8888Y'"))
|
||||||
|
|
||||||
|
(defparameter *colors*
|
||||||
|
'((main . (:green :black))
|
||||||
|
(figlet . (:black :white))
|
||||||
|
(selected-highlight . (:blue :black))
|
||||||
|
(unselected-highlight . (:white :black))))
|
||||||
|
|
||||||
|
;; Returns (y, x) to draw box to center it in screen
|
||||||
|
(defun center-box (screen width height)
|
||||||
|
(let ((sw (croatoan:width screen))
|
||||||
|
(sh (croatoan:height screen)))
|
||||||
|
(list (round (- (/ sh 2) (/ height 2))) (round (- (/ sw 2) (/ width 2))))))
|
||||||
|
|
||||||
|
(defun write-horizontal-slice-list (scr pos slices)
|
||||||
|
(let ((yi (car pos)))
|
||||||
|
(mapcar (lambda (s)
|
||||||
|
(croatoan:add scr s :position `(,yi ,(cadr pos)))
|
||||||
|
(inc yi))
|
||||||
|
slices)))
|
||||||
|
|
||||||
|
;; Draws a list of strings horizontally in a window with padding and an optional border
|
||||||
|
(defun figlet-window (title-slices scr pos &key (padding 2) (border nil))
|
||||||
|
(let* ((width (+ (reduce (lambda (a x) (max a x)) (mapcar #'length title-slices)) (* 2 padding)))
|
||||||
|
(height (+ (length *lispruns-logo*) (* 2 padding)))
|
||||||
|
(title-box (make-instance 'croatoan:window
|
||||||
|
:border border
|
||||||
|
:width width
|
||||||
|
:height height
|
||||||
|
:position pos)))
|
||||||
|
(setf (croatoan:background title-box) (make-instance 'croatoan:complex-char :color-pair (cdr (assoc 'figlet *colors*))))
|
||||||
|
(write-horizontal-slice-list title-box `(,padding ,padding) title-slices)
|
||||||
|
title-box))
|
||||||
|
|
||||||
|
(defclass highlight-list ()
|
||||||
|
((scroll-i
|
||||||
|
:initarg :scroll-i
|
||||||
|
:accessor highlight-list-scroll-i)
|
||||||
|
(elements
|
||||||
|
:initarg :elements
|
||||||
|
:accessor highlight-list-elements)
|
||||||
|
(current-element-index
|
||||||
|
:initarg :current-element-index
|
||||||
|
:accessor highlight-list-current-element-index)
|
||||||
|
(height
|
||||||
|
:initarg :height
|
||||||
|
:accessor highlight-list-height)
|
||||||
|
(width
|
||||||
|
:initarg :width
|
||||||
|
:accessor highlight-list-width)))
|
||||||
|
|
||||||
|
(defun highlight-list-window (hl pos)
|
||||||
|
(let* ((width (- (highlight-list-width hl) 2))
|
||||||
|
(height (- (highlight-list-height hl) 2))
|
||||||
|
(elements (highlight-list-elements hl))
|
||||||
|
(current-element-index (highlight-list-current-element-index hl))
|
||||||
|
(elements-to-draw-subseq (if (>= height (length elements))
|
||||||
|
(list 0 (1- (length elements)))
|
||||||
|
(cond
|
||||||
|
((> height (1+ current-element-index))
|
||||||
|
(list 0 height))
|
||||||
|
((< (- (length elements) height) current-element-index)
|
||||||
|
(list (- (length elements) height) (length elements)))
|
||||||
|
(t (let ((dy (/ (1- height) 2)))
|
||||||
|
(list (- current-element-index (floor dy)) (1+ (+ current-element-index (ceiling dy)))))))))
|
||||||
|
(highlight-menu (make-instance 'croatoan:window
|
||||||
|
:border t
|
||||||
|
:width (+ 2 width)
|
||||||
|
:height (+ 2 height)
|
||||||
|
:position pos)))
|
||||||
|
(let ((yi 0))
|
||||||
|
(mapcar (lambda (el)
|
||||||
|
(setf (croatoan:color-pair highlight-menu)
|
||||||
|
(if (equal (+ yi (car elements-to-draw-subseq)) current-element-index)
|
||||||
|
(cdr (assoc 'selected-highlight *colors*))
|
||||||
|
(cdr (assoc 'unselected-highlight *colors*))))
|
||||||
|
(inc yi)
|
||||||
|
(croatoan:add highlight-menu el :position `(,yi 1)))
|
||||||
|
(subseq elements (car elements-to-draw-subseq) (cadr elements-to-draw-subseq))))
|
||||||
|
highlight-menu))
|
||||||
|
|
||||||
|
(defun run-ui ()
|
||||||
|
(croatoan:with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil :enable-colors t :input-buffering nil :input-blocking nil)
|
||||||
|
(croatoan:clear scr)
|
||||||
|
(croatoan:refresh scr)
|
||||||
|
(setf (croatoan:background scr) (make-instance 'croatoan:complex-char :color-pair (cdr (assoc 'main *colors*))))
|
||||||
|
(croatoan:draw-border scr)
|
||||||
|
|
||||||
|
(defvar windows '())
|
||||||
|
(defvar current-index 0)
|
||||||
|
(croatoan:event-case (scr event)
|
||||||
|
(#\b
|
||||||
|
(let ((hl (make-instance 'highlight-list
|
||||||
|
:scroll-i 0
|
||||||
|
:elements '("HELLO" "WORLD" "MY" "NAME" "IS" "LOGAN" "HUNT" "AND" "I" "LIKE" "PIZZA")
|
||||||
|
:current-element-index current-index
|
||||||
|
:height 6
|
||||||
|
:width 10)))
|
||||||
|
(push (highlight-list-window hl '(20 20)) windows))
|
||||||
|
(push (figlet-window *lispruns-logo* scr '(2 2)) windows)
|
||||||
|
(inc current-index))
|
||||||
|
(#\q (return-from croatoan:event-case))
|
||||||
|
(#\c (croatoan:clear scr))
|
||||||
|
(:resize nil)
|
||||||
|
((nil)
|
||||||
|
(mapcar #'croatoan:refresh (cons scr windows))
|
||||||
|
(sleep (/ 1 60))))))
|
||||||
55
util.lisp
Normal file
55
util.lisp
Normal file
@ -0,0 +1,55 @@
|
|||||||
|
;; For big ascii-art digits
|
||||||
|
(load "digits.lisp")
|
||||||
|
|
||||||
|
(defmacro inc (x)
|
||||||
|
`(setf ,x (1+ ,x)))
|
||||||
|
|
||||||
|
;; Wraps text and adds ellipsis if it doesn't fit within width, scrolling
|
||||||
|
;; by index i
|
||||||
|
(defun maybe-wrap-text (text width i)
|
||||||
|
(let ((textlen (length text)))
|
||||||
|
(if (>= width textlen)
|
||||||
|
text
|
||||||
|
(let* ((max-width (1- width))
|
||||||
|
(max-wrap (1+ (- textlen max-width)))
|
||||||
|
(wrap-i (rem i max-wrap)))
|
||||||
|
(concatenate 'string (subseq text wrap-i (+ wrap-i (min max-width textlen))) "-")))))
|
||||||
|
|
||||||
|
;; Makes a-list with '((hours . HOURS) (minutes . MINUTES) (seconds . SECONDS) (ms . MILLISECONDS))
|
||||||
|
(defun make-time-alist (ms)
|
||||||
|
`((hours . ,(floor (/ ms (* 1000 60 60))))
|
||||||
|
(minutes . ,(floor (mod (/ ms (* 1000 60)) 60)))
|
||||||
|
(seconds . ,(floor (mod (/ ms 1000) 60)))
|
||||||
|
(ms . ,(mod ms 1000))))
|
||||||
|
|
||||||
|
|
||||||
|
;; Add a list of strings representing horizontal slices of a character to another list of strings representing horizontal slices of a string, or create a new list of horizontal slices if the original was empty.
|
||||||
|
;; Character height will be truncated to the height of the first character in the slices.
|
||||||
|
(defun add-to-horizontal (character horizontal-layers &key (seperator " "))
|
||||||
|
(let ((layer-height (length horizontal-layers)))
|
||||||
|
(loop for i from 0 to (1- (if (zerop layer-height) (length character) layer-height))
|
||||||
|
collect
|
||||||
|
(let ((layer (nth i horizontal-layers))
|
||||||
|
(character-slice (nth i character)))
|
||||||
|
(if (and layer (> (length layer) 0))
|
||||||
|
(concatenate 'string layer seperator character-slice)
|
||||||
|
character-slice)))))
|
||||||
|
|
||||||
|
;; Formats, disregarding min/hour if they shouldn't be shown, a time alist to "H:M:S.ms"
|
||||||
|
(defun format-time (time-alist)
|
||||||
|
(let
|
||||||
|
((hours (cdr (assoc 'hours time-alist)))
|
||||||
|
(minutes (cdr (assoc 'minutes time-alist)))
|
||||||
|
(seconds (cdr (assoc 'seconds time-alist)))
|
||||||
|
(centis (round (/ (cdr (assoc 'ms time-alist)) 10))))
|
||||||
|
(concatenate 'string
|
||||||
|
(unless (zerop hours) (format nil "~2,'0d:" hours))
|
||||||
|
(unless (and (zerop minutes) (zerop hours)) (format nil "~2,'0d:" minutes))
|
||||||
|
(format nil "~2,'0d.~2,'0d" seconds centis))))
|
||||||
|
|
||||||
|
;; Creates a list of horizontal slices to display a formatted larger string by using figlet characters
|
||||||
|
(defun lispglet (str &optional (char-hashes *big-digits*))
|
||||||
|
(loop for horizontal-layers = '()
|
||||||
|
then (add-to-horizontal (gethash c char-hashes) horizontal-layers)
|
||||||
|
for c across str
|
||||||
|
finally (return horizontal-layers)))
|
||||||
Loading…
Reference in New Issue
Block a user