Compare commits

..

No commits in common. "master" and "main" have entirely different histories.
master ... main

18 changed files with 807 additions and 213 deletions

3
.gitignore vendored Normal file
View File

@ -0,0 +1,3 @@
*.db
*.env
bin

14
README.markdown Normal file
View File

@ -0,0 +1,14 @@
# SBCL Speedrun Timer
This is a complete rewrite of my first Lisp project: a speedrun timer. It uses the amazing ncurses wrapper library [croatoan](https://github.com/McParen/croatoan) and a SQLite database - with the [MITO ORM](https://github.com/fukamachi/mito).
https://user-images.githubusercontent.com/25559600/204612689-05c2bbab-5130-43b0-8b09-f3a9583c506b.mp4
## Requirements
+ [Quicklisp](https://www.quicklisp.org/beta/)
+ [SBCL](http://www.sbcl.org/platform-table.html)
+ [SQLite](https://www.sqlite.org/download.html)
## Usage
1. Load the package: `sbcl --load lispruns.asd`
2. Get dependencies: `(ql:quickload 'lispruns)`
3. `(main)`

View File

@ -0,0 +1,18 @@
[category]
:name Super Mario 64
:percentage 16 Stars Any%
[splits]
:name Bobomb Battlefield
:name Whomp's Fortress
:name Cool Cool Mountain
:name Bowser in the Dark World
:name Shifting Sand Land
:name Lethal Lava Land
:name Hazy Maze Cave
:name MIPS Clip
:name Dire, dire docks
:name Bowser in the Fire Sea
:name BLJ's
:name Bowser in the Sky

View 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!

84
config.lisp Normal file
View File

@ -0,0 +1,84 @@
;; 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
((nonempty-p current-section)
(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 (not (nonempty-p current-section))
(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-category (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)))

17
database/category.lisp Normal file
View File

@ -0,0 +1,17 @@
(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 :accessor category-split-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)))

81
database/run.lisp Normal file
View File

@ -0,0 +1,81 @@
(mito:deftable run ()
((category :col-type category :accessor run-category))
(:record-timestamps nil)
(:conc-name run-))
(mito:deftable run-split ()
((run :col-type run :accessor run-split-run)
(category-split :col-type category-split :accessor run-split-category-split)
(start-timestamp :col-type (or :bigint :null))
(end-timestamp :col-type (or :bigint :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))))
(defun delete-run (run)
(let ((splits (run-splits run)))
(mapcar 'mito:delete-dao (cons run splits))))
;; Returns the elapsed time in milliseconds since split started to either
;; current time or the split's end time
(defun run-split-elapsed-time (run-split)
(let ((start (ignore-errors (run-split-start-timestamp run-split)))
(end (or (ignore-errors (run-split-end-timestamp run-split)) (get-internal-real-time))))
(if start
(- end start))))
(defun run-split-format-elapsed-time (run-split)
(let ((elapsed (run-split-elapsed-time run-split)))
(if elapsed
(format-time (make-time-alist (millis-since-internal-timestamp 0 elapsed)))
"-")))
(defmacro query-with-runs-elapsed (&rest body)
`(mito:retrieve-by-sql
(sxql:select (:* (:as (:sum (:* (:/ (:raw "end_timestamp - CAST(start_timestamp AS REAL)") ,internal-time-units-per-second) 1000)) :elapsed))
(sxql:from :run_split)
(sxql:group-by :run_id)
,@body)))
(defun best-category-run (category)
(car (query-with-runs-elapsed
(sxql:inner-join :run :on (:= :run_id :run.id))
(sxql:order-by :elapsed)
(sxql:limit 1)
(sxql:where (:= :category_id (mito:object-id category))))))
(defun best-category-split (category-split)
(car (query-with-runs-elapsed
(sxql:inner-join :category_split :on (:= :category_split_id :category_split.id))
(sxql:order-by :elapsed)
(sxql:limit 1)
(sxql:where (:= :category_split_id (mito:object-id category-split))))))
(defun list-runs (&key (order-element :id) (direction :asc))
(query-with-runs-elapsed
(sxql:inner-join :run :on (:= :run_id :run.id))
(sxql:inner-join :category :on (:= :category_id :category.id))
(sxql:order-by (list direction order-element))))
(defun list-category-runs (category &key (order-element :elapsed) (direction :asc))
(query-with-runs-elapsed
(sxql:inner-join :run :on (:= :run_id :run.id))
(sxql:order-by (list direction order-element))
(sxql:where (:= :category_id (mito:object-id category)))))
(defun statistics (category)
(let ((csplits (category-splits category)))
`((SPLIT-PBS . ,(mapcar (lambda (csplit) (getf (best-category-split csplit) :ELAPSED)) csplits))
(BEST-CATEGORY-RUN-SPLITS . ,(or
(mapcar (lambda (split)
(millis-since-internal-timestamp 0 (run-split-elapsed-time split)))
(ignore-errors
(run-splits (mito:find-dao 'run :id (getf (best-category-run category) :RUN-ID)))))
(mapcar (lambda (csplit) nil) csplits))))))

62
digits.lisp Normal file
View 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 (" ___ "
" / _ \\ "
"| (_) |"
" \\__, |"
" /_/ "))
(#\. (" "
" "
" "
" _ "
"(_)"))
(#\: (" _ "
"(_)"
" "
" _ "
"(_)"))))

View File

@ -1,89 +0,0 @@
(ql:quickload "cl-charms")
;; Splits are in the following format
;; (name elapsed-time-for-split best-split split-pb)
(defvar *interval* internal-time-units-per-second)
(defvar *splits*
'(
("Chozo" 0 0 0)
("Kraid" 0 0 0)
("Wave Beam" 0 0 0)
("Phantoon" 0 0 0)
("Botwoon" 0 0 0)
("Draygon" 0 0 0)
("Lower Norfair" 0 0 0)
("Ridley" 0 0 0)
("Mother Brain" 0 0 0)))
(defvar *all-splits* '())
(defun set-val-in-list (list index value)
(cond
((null list) '())
((zerop index) (cons value (cdr list)))
(t (cons (car list) (set-val-in-list (cdr list) (1- index) value)))))
(defun get-val-in-list (list index)
(cond
((null list) nil)
((zerop index) (car list))
(t (get-val-in-list (cdr list) (1- index)))))
(defun push-on-list (value list)
(cond
((null list) (list value))
(t (cons (car list) (push-on-list value (cdr list))))))
(defun read-file-of-splits (filename)
(with-open-file (in filename)
(with-standard-io-syntax
(setf *all-splits* (read in)))))
(defun write-file-of-splits (filename splits)
(with-open-file (output filename)
:direction :output
:if-exists :supersede
(with-standard-io-syntax
(print splits output))))
(defun print-character-times (n char)
(cond
((zerop n) "")
(t
(concatenate 'string (format nil "~a" char) (print-character-times (1- n) char)))))
(defun center-string (string length)
(concatenate
'string
(print-character-times (floor (/ (- length (length string)) 2)) " ")
(format nil "~a" string)
(print-character-times (ceiling (/ (- length (length string)) 2)) " ")))
(defun time-to-milliseconds (time)
(* (/ time *interval*) 1000))
(defun format-time (milliseconds)
(let*
((hours (floor (/ milliseconds (* 1000 60 60))))
(minutes (floor (mod (/ milliseconds (* 1000 60)) 60)))
(seconds (floor (mod (/ milliseconds 1000) 60)))
(centis (mod (floor (/ milliseconds 10)) 100)))
(format
nil "~a"
(concatenate
'string
(cond ((zerop hours) "") (t (format nil "~2,'0D:" hours)))
(cond ((zerop minutes) "") (t (format nil "~2,'0D:" minutes)))
(format nil "~2,'0D." seconds)
(format nil "~2,'0D" centis)))))
(defun format-split (split)
(cond
((null split) "")
(t
(concatenate
'string
(cond
((numberp (car split))
(format nil "~a|" (center-string (format-time (car split)) 12)))
(t (format nil "|~a|" (center-string (car split) 15))))
(format-split (cdr split))))))

23
lispruns.asd Normal file
View File

@ -0,0 +1,23 @@
(asdf:defsystem "lispruns"
:description "A speedrun timer using n-curses written in lisp"
:version "0.1"
:author "Simponic"
:depends-on (:mito
:sxql
:cl-ppcre
:croatoan)
:components ((:file "util") ;; Miscellaneous helpers
(:file "config") ;; For importing category configuration files
(:file "digits") ;; Lisp file with cool ascii digits
(:file "text" :depends-on ("digits")) ;; Helper functions for performing figlet-like actions and such
(:file "time") ;; Custom time forms
(:file "ui" :depends-on ("util" "text" "time")) ;; Functions to draw the UI
(:file "speedrun" :depends-on ("util")) ;; The actual timer logic
(:file "database/category") ;; Category DAO
(:file "database/run") ;; Run DAO
(:file "main" :depends-on ("database/category"
"database/run"
"util"
"config"
"ui"
"speedrun"))))

209
main.lisp
View File

@ -1,59 +1,156 @@
(load "helper.lisp")
(load "splits.lisp")
;; 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")
(defvar current-split '())
(defvar done-splits '())
(defvar last-time-space-pressed 0)
(defvar pb 0)
(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'"))
(defun read-in-splits (filename)
(cond
((y-or-n-p "Read file")
(read-file-of-splits filename)
(setf
*splits*
(set-column-in-run-from-other-run
2
(make-run-of-best-segments *all-splits* 0)
*splits*))
(setf
*splits*
(set-column-in-run-from-other-run
3
(get-best-run *all-splits* (car *all-splits*) (cadr (car *splits*)))
*splits*))))
(setf pb (sum-splits *splits* 3))
(setf current-split (car *splits*))
(setf *splits* (cdr *splits*))
)
(defun main (filename)
(read-in-splits filename)
(setf last-time-space-pressed (get-internal-real-time))
(charms:with-curses ()
(charms:disable-echoing)
(charms:enable-raw-input :interpret-control-characters t)
(charms:enable-non-blocking-mode charms:*standard-window*)
(loop :named driver-loop
:for c := (charms:get-char charms:*standard-window*
:ignore-error t)
:do (progn
(charms:clear-window charms:*standard-window*)
(if (null current-split) (return-from driver-loop))
(charms:write-string-at-point charms:*standard-window* (make-output (push-on-list current-split done-splits) 0 pb) 0 0)
(charms:refresh-window charms:*standard-window*)
(setf current-split (update-split current-split last-time-space-pressed))
(case c
((nil) nil)
((#\Space)
(defun get-input (prompt &optional (validator 'nonempty-p))
(clear-input)
(write-string prompt)
(finish-output)
(let ((input (read-line)))
(if (ignore-errors (funcall validator input))
input
(progn
(setf last-time-space-pressed (get-internal-real-time))
(setf done-splits (push-on-list current-split done-splits))
(setf current-split (car *splits*))
(setf *splits* (cdr *splits*))))
((#\q) (return-from driver-loop)))
(sleep 0.01)
)))
(setf *all-splits* (cons done-splits *all-splits*))
(cond ((y-or-n-p "Save?") (with-open-file (output filename :direction :output :if-exists :supersede) (print *all-splits* output))))
(format nil (format-time (sum-splits done-splits 1))))
(format t "E: Invalid input. Try again.~%")
(get-input prompt validator)))))
;; Options is an alist with the prompt string as the car and the value as the cdr
(defun select-option (options)
(let ((i 0))
(loop for x in options
do
(inc i)
(format t " [~a] ~a~%" i (car x))))
(let ((user-input (get-input (format nil "Select [~a - ~a] or search: " 1 (length options)))))
(if (every #'digit-char-p user-input)
;; Selected by option index
(let ((user-integer (parse-integer user-input)))
(if (and (>= user-integer 1) (<= user-integer (length options)))
(cdr (nth (1- user-integer) options))
(progn
(format t "E: Not a valid selection.~%")
(select-option options))))
;; Search for user string, either select the one it matches or recursively call select-option on the matched options
(let* ((scanner (cl-ppcre:create-scanner user-input :case-insensitive-mode t))
(filtered
(remove-if-not
(lambda (option) (cl-ppcre:scan scanner (car option)))
options)))
(if filtered
(case (length filtered)
(1 (let ((searched (car filtered)))
(if (y-or-n-p "Use \"~a\"" (car searched))
(cdr searched)
(select-option options))))
(t
(format t "That search came up with multiple results:~%")
(select-option filtered)))
(progn (format t "E: Could not find option that matched query.~%")
(select-option options)))))))
(defun user-create-new-category ()
(let* ((name (get-input "Category Name (e.g. \"SM64\"): "))
(percentage (get-input "Percentage (e.g. \"Any% 16 Star\"): "))
(category (mito:insert-dao (make-instance 'category :name name :percentage percentage)))
(splits (do ((spliti 1 (1+ spliti))
(inputs '() (push (get-input (format nil "Split Name [~a]~a: " spliti (if (<= spliti 1) " (blank when done adding)" "")) (lambda (x) t)) inputs)))
((equal (car inputs) "")
(mapcar (lambda
(category-split-name)
(mito:insert-dao
(make-instance 'category-split
:name category-split-name
:category category)))
(reverse (cdr inputs)))))))
(if splits
(format t "Successfully created category~%"))))
(defun with-selected-category (f)
(let* ((categories (mito:select-dao 'category))
(category-alist (mapcar (lambda (category) `(,(format nil "~a - ~a" (category-name category) (category-percentage category)) . ,category)) categories)))
(if categories
(funcall f (select-option category-alist))
(format t "E: There are no categories. Try creating one or importing one~%"))))
(defun with-selected-speedrun (f)
(let* ((filter (select-option '(("Choose from a category" . CATEGORY) ("List runs from all categories" . ALL))))
(runs
(case filter
('CATEGORY (with-selected-category 'list-category-runs))
('ALL (list-runs))))
(run-details-alist (mapcar (lambda (run-detail)
`(,(let ((formatted-elapsed (format-time (make-time-alist (getf run-detail :ELAPSED))))
(category-name (getf run-detail :NAME))
(category-percentage (getf run-detail :PERCENTAGE)))
(apply 'format
(if (and category-name category-percentage)
`(nil "~a - ~a | ~a" ,category-name ,category-percentage ,formatted-elapsed)
`(nil "~a" ,formatted-elapsed))))
. ,(mito:find-dao 'run :id (getf run-detail :RUN-ID))))
runs)))
(if run-details-alist
(funcall f (select-option run-details-alist))
(progn
(format t "E: No runs found~%")
(if (y-or-n-p "Go back?")
nil
(with-selected-speedrun f))))))
(defun main ()
(let ((choice (select-option '(("Help" . HELP)
("Import a category" . IMPORT-CATEGORY)
("Make a new category" . NEW-CATEGORY)
("Start a speedrun" . START-SPEEDRUN)
("View splits of a speedrun" . VIEW-SPEEDRUNS)
("Delete a category" . DELETE-CATEGORY)
("Delete a speedrun" . DELETE-SPEEDRUN)
("Exit" . EXIT)))))
(case choice
('HELP
(format t "~%")
(mapcar #'(lambda (x) (format t "~a~%" x)) *lispruns-logo*)
(format t "Welcome to Lispruns!~%"))
('IMPORT-CATEGORY
(if (import-category (get-input
(format nil "Relative or absolute path to configuration file [~a]: "
(uiop/os:getcwd))
'probe-file))
(format t "Successfully imported category~%")))
('NEW-CATEGORY
(user-create-new-category))
('START-SPEEDRUN
(with-selected-category 'speedrun-ui))
('DELETE-SPEEDRUN
(with-selected-speedrun 'mito:delete-dao))
('DELETE-CATEGORY
(with-selected-category (lambda (category)
(let ((runs
(mapcar
(lambda (run-detail) (mito:find-dao 'run :id (getf run-detail :RUN-ID)))
(list-category-runs category))))
(mapcar 'delete-run runs))
(mito:delete-dao category)))
(format t "Deleted category~%"))
('VIEW-SPEEDRUNS
(with-selected-speedrun (lambda (run)
(let ((csplits (category-splits (run-category run)))
(rsplits (run-splits run)))
(mapcar (lambda (csplit rsplit)
(format t " ~a~%" (format-line `((,(category-split-name csplit) . ,(/ 3 10))
("|" . ,(/ 1 10))
(,(run-split-format-elapsed-time rsplit) . ,(/ 6 10)))
70 0)))
csplits rsplits)))))
('EXIT
(quit))))
(format t "~%")
(main))

73
speedrun.lisp Normal file
View File

@ -0,0 +1,73 @@
(defclass speedrun ()
((state
;; RUNNING, STOPPED
:initarg :state
:accessor speedrun-state)
(title
:initarg :title
:accessor speedrun-title)
(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) (millis-since-internal-timestamp (speedrun-start-timestamp speedrun)))))
;; Initializes a speedrun to start running the timer
(defun start-speedrun (speedrun)
(let ((now (get-internal-real-time)))
(setf (speedrun-state speedrun) 'RUNNING
(speedrun-start-timestamp speedrun) now
(run-split-start-timestamp (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))))
;; Set the state of the speedrun to be stopped if there are no more splits.
;; Or, set the current split to the next one in the list.
(defun next-split (speedrun)
(let ((now (get-internal-real-time)))
(unless (equal (speedrun-state speedrun) 'STOPPED)
(setf (run-split-end-timestamp (current-split speedrun)) now)
(if (equal (speedrun-current-split-index speedrun) (1- (length (speedrun-splits speedrun))))
(progn
(setf
;; Since timer computation can get +-0.02 seconds out of sync of splits, just set it to the sum of the splits' elapsed time
(speedrun-elapsed speedrun) (millis-since-internal-timestamp 0 (apply '+ (mapcar 'run-split-elapsed-time (speedrun-splits speedrun))))
(speedrun-state speedrun) 'STOPPED)
(save-speedrun speedrun))
(progn
(inc (speedrun-current-split-index speedrun))
(setf (run-split-start-timestamp (current-split speedrun)) now))))))

View File

@ -1,67 +0,0 @@
(load "helper.lisp")
(defun sum-splits (splits at-index)
(cond ((null splits) 0)
(t (+ (get-val-in-list (car splits) at-index) (sum-splits (cdr splits) at-index)))))
(defun get-best-run (list-of-runs current-best-run current-minimum)
(cond
((null list-of-runs) current-best-run)
(t
(let ((current-sum (sum-splits (car list-of-runs) 1)))
(cond
((< current-sum current-minimum) (get-best-run (cdr list-of-runs) (car list-of-runs) (cadr (car list-of-runs))))
(t (get-best-run (cdr list-of-runs) current-best-run current-minimum)))))))
(defun get-best-split (list-of-runs split-index current-minimum-split current-minimum-time)
(cond
((null list-of-runs) current-minimum-split)
(t
(let*
((current-split (get-val-in-list (car list-of-runs) split-index))
(current-time (get-val-in-list current-split 1)))
(cond
((< current-time current-minimum-time)
(get-best-split (cdr list-of-runs) split-index current-split current-time))
(t
(get-best-split (cdr list-of-runs) split-index current-minimum-split current-minimum-time)))))))
(defun make-run-of-best-segments (list-of-runs index)
(cond
((null list-of-runs) '())
((null (get-val-in-list (car list-of-runs) index)) '())
(t
(cons
(get-best-split list-of-runs index (get-val-in-list (car list-of-runs) index) (sum-splits (car list-of-runs ) 1))
(make-run-of-best-segments list-of-runs (1+ index))))))
(defun update-split (current-split start-time)
(set-val-in-list
current-split
1
(time-to-milliseconds (- (get-internal-real-time) start-time))))
(defun set-column-in-run-from-other-run (column_index run_to_copy list-of-splits)
(cond
((null list-of-splits) nil)
(t
(cons
(set-val-in-list
(car list-of-splits) column_index (get-val-in-list (car run_to_copy) 1))
(set-column-in-run-from-other-run
column_index (cdr run_to_copy) (cdr list-of-splits))))))
(defun make-output (splits current-sum pb)
(cond
((null splits)
(format nil "~%| Current time: |~a|~%| PB: |~a|" (center-string (format-time current-sum) 12) (center-string (format-time pb) 12)))
(t
(concatenate
'string
(format nil "~a~%" (format-split (car splits)))
(make-output
(cdr splits)
(+ current-sum (get-val-in-list (car splits) 1))
pb)))))

53
text.lisp Normal file
View File

@ -0,0 +1,53 @@
;; Pads string 's' on the right by 'width'
(defun pad-right-string (s width)
(format nil (concatenate 'string "~" (write-to-string width) "a") s))
;; Wraps text and adds a hypen if it doesn't fit within (1- 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))) "-")))))
;; line is an alist containing the string as the first element and the
;; fraction of the maximum width "max-width" the whole line should take up (these should
;; add up to 1)
;; scroll-i is the index the string is truncated to with a hyphen (see maybe-wrap-text)
;; ex. (format-line `(("Hello, world" . ,(/ 2 5))
;; ("" . ,(/ 1 5))
;; ("Hello, again" . ,(/ 2 5)))
;; 20 2)
;; -> "llo, wo- llo, ag-"
(defun format-line (line max-width &optional (scroll-i 0) (formatted ""))
(if (eq line nil)
formatted
(if (listp line)
(let* ((curr (car line))
(text-width (floor (* max-width (cdr curr))))
(wrapped-string (maybe-wrap-text (car curr) text-width scroll-i))
(current-string (pad-right-string wrapped-string text-width)))
(format-line (cdr line) max-width scroll-i (concatenate 'string formatted current-string)))
(pad-right-string (maybe-wrap-text line max-width scroll-i) max-width))))
;; 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)))))
;; 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)))

20
time.lisp Normal file
View File

@ -0,0 +1,20 @@
(defun millis-since-internal-timestamp (start-timestamp &optional (end-timestamp (get-internal-real-time)))
(ceiling (* 1000 (/ (- end-timestamp start-timestamp) internal-time-units-per-second))))
(defun make-time-alist (millis)
`((hours . ,(floor (/ millis (* 1000 60 60))))
(minutes . ,(floor (mod (/ millis (* 1000 60)) 60)))
(seconds . ,(floor (mod (/ millis 1000) 60)))
(millis . ,(mod millis 1000))))
;; 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 (floor (/ (cdr (assoc 'millis 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))))

View File

@ -1 +0,0 @@

178
ui.lisp Normal file
View File

@ -0,0 +1,178 @@
(defparameter *colors*
'((main . (:green :black))
(timer-box . (:green :black))
(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))))))
;; Write a list of horizontal slices to the screen scr at position pos
(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)))
;; Formats a category split and a run split for the splits window
(defun make-split-line (csplit speedrun-split pb)
(let ((split-elapsed (run-split-elapsed-time speedrun-split))
(format-split-elapsed (run-split-format-elapsed-time speedrun-split)))
`((,(category-split-name csplit) . ,(/ 4 12))
("" . ,(/ 1 12))
(,format-split-elapsed . ,(/ 3 12))
("" . ,(/ 1 12))
(,(if pb
(let ((split-end-timestamp (ignore-errors (run-split-end-timestamp speedrun-split))))
(if split-end-timestamp
(let ((elapsed-diff (- (millis-since-internal-timestamp 0 split-elapsed) pb)))
(concatenate 'string (if (plusp elapsed-diff) "+" "-") (format-time (make-time-alist (abs elapsed-diff)))))
(format-time (make-time-alist pb))))
format-split-elapsed)
. ,(/ 3 12)))))
;; Creates a window with the total time and statistics
(defun timer-window (speedrun pos width height)
(let* ((timerglet (lispglet (format-time (make-time-alist (speedrun-elapsed speedrun)))))
(timer-box (make-instance 'croatoan:window
:border t
:position pos
:width width
:height height)))
(setf (croatoan:color-pair timer-box) (cdr (assoc 'timer-box *colors*)))
(write-horizontal-slice-list timer-box '(1 1) timerglet)
timer-box))
;; Class to hold state for a list where one element is highlighted/selected
(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)))
;; Create the actual window to render a highlight list hl at position pos
(defun highlight-list-window (hl pos)
(let* ((width (- (highlight-list-width hl) 2)) ;; Magic number 2's are for the border on both sides
(height (- (highlight-list-height hl) 2))
(elements (highlight-list-elements hl))
(current-element-index (mod (highlight-list-current-element-index hl) (length elements)))
(elements-to-draw-subseq (if (>= height (length elements))
(list 0 (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) ;; Another magic 2
: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
(format-line el width (highlight-list-scroll-i hl))
:position `(,yi 1)))
(subseq elements (car elements-to-draw-subseq) (cadr elements-to-draw-subseq))))
highlight-menu))
;; The big bad monolithic UI loop
(defun speedrun-ui (category)
(croatoan:with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil :enable-colors t :input-buffering nil :input-blocking nil)
(setf (croatoan:background scr) (make-instance 'croatoan:complex-char :color-pair (cdr (assoc 'main *colors*))))
;; Create a closure over the UI state
(let* ((scroll 0)
(frame 0)
(state 'TITLE)
(redraws '(title-instance))
(speedrun (make-speedrun category))
(csplits (category-splits category))
(bests (statistics category))
(split-pbs (cdr (assoc 'SPLIT-PBS bests)))
(best-category-run-pbs (cdr (assoc 'BEST-CATEGORY-RUN-SPLITS bests))))
(flet ((render ()
(case state
('TITLE
(if (member 'title-instance redraws)
(croatoan:clear scr)
(let* ((padding 4)
(title (append *lispruns-logo* '("" "CONTROLS" " SPACE to start and to continue to the next split" " Q to quit")))
(width (+ (* 2 padding) (max-length title)))
(height (+ (* 2 padding) (length title)))
(logo-centered (center-box scr width height))
(logo-box (make-instance 'croatoan:window :border t :width width :height height :position logo-centered)))
(if (< (croatoan:width scr) width)
(progn
(croatoan:add scr "Please increase width of your terminal" :position '(0 0))
(croatoan:refresh scr))
(progn
(write-horizontal-slice-list logo-box `(,padding ,padding) title)
(croatoan:refresh logo-box))))))
('RUNNING
(if (eq (speedrun-state speedrun) 'RUNNING)
(update-time speedrun))
(if (member 'timer-instance redraws)
(croatoan:clear scr))
(if (zerop (mod frame 4))
(let* ((max-width (min 90 (croatoan:width scr)))
(centered-x (cadr (center-box scr max-width 0)))
(timer-height 8)
(splits-height (- (croatoan:height scr) timer-height))
(split-list (make-instance 'highlight-list
:scroll-i scroll
:current-element-index (speedrun-current-split-index speedrun)
:height splits-height
:width max-width
;; Todo: add personal bests to elements
:elements (mapcar 'make-split-line csplits (speedrun-splits speedrun) best-category-run-pbs)))
(splits-instance (highlight-list-window split-list `(0 ,centered-x)))
(timer-instance (timer-window speedrun `(,splits-height ,centered-x) max-width timer-height)))
(croatoan:refresh splits-instance)
(croatoan:refresh timer-instance)))))
(setf redraws '()
frame (mod (1+ frame) 60))
(if (zerop (mod frame 30))
(inc scroll))
(sleep (/ 1 60))))
(croatoan:event-case (scr event)
(#\q (return-from croatoan:event-case))
(#\space
(case state
('TITLE
(start-speedrun speedrun)
(setf redraws '(timer-instance))
(setf state 'RUNNING))
('RUNNING (next-split speedrun))))
(:resize
(case state
('TITLE
(setf redraws '(title-instance)))
('RUNNING
(croatoan:clear scr)))
(render))
((nil) (render)))))))

14
util.lisp Normal file
View File

@ -0,0 +1,14 @@
(defmacro inc (x &optional (val 1))
`(setf ,x (+ ,val ,x)))
;; For system arguments
(defmacro when-option ((options opt) &body body)
`(let ((it (getf ,options ,opt)))
(when it
,@body)))
(defun max-length (lists)
(reduce (lambda (a x) (max a x)) (mapcar #'length lists)))
(defun nonempty-p (s)
(not (zerop (length s))))