simponic/speedrun-timer
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Compare commits

base: simponic:master
Branches Tags
simponic:main
simponic:master
..
compare: simponic:main
Branches Tags
simponic:main
simponic:master

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

18 changed files with 807 additions and 213 deletions
Show Stats Expand all files Collapse all files

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)`

18
categories/sm64-any-16-stars.conf Normal file
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

14
categories/supermetroid-any-kpdr.conf Normal file
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 (" ___ "
" / _ \\ "
"| (_) |"
" \\__, |"
" /_/ "))
(#\. (" "
" "
" "
" _ "
"(_)"))
(#\: (" _ "
"(_)"
" "
" _ "
"(_)"))))

89
helper.lisp
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))))))

67
splits.lisp
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))))

1
times.txt
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))))