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

None of the original commit messages would actually help anyone

Browse Source
This commit is contained in:
Logan Hunt 2022-05-24 09:57:15 -07:00
commit 3db9a2eb7a
12 changed files with 491 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored Normal file
View File

@ -0,0 +1,2 @@
*.db
*.env

10
README.org Normal file
View 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
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!

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

39
main.lisp Normal file
View 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
View 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
View 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
View 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)))