From 3db9a2eb7a7d14ce935f5902b0c21ce4fd5eb729 Mon Sep 17 00:00:00 2001 From: Logan Hunt Date: Tue, 24 May 2022 09:57:15 -0700 Subject: [PATCH] None of the original commit messages would actually help anyone --- .gitignore | 2 + README.org | 10 +++ categories/supermetroid-any-kpdr.conf | 14 ++++ config.lisp | 85 +++++++++++++++++++ database/category.lisp | 19 +++++ database/run.lisp | 17 ++++ database/seeds.lisp | 8 ++ digits.lisp | 62 ++++++++++++++ main.lisp | 39 +++++++++ speedrun.lisp | 67 +++++++++++++++ ui.lisp | 113 ++++++++++++++++++++++++++ util.lisp | 55 +++++++++++++ 12 files changed, 491 insertions(+) create mode 100644 .gitignore create mode 100644 README.org create mode 100644 categories/supermetroid-any-kpdr.conf create mode 100644 config.lisp create mode 100644 database/category.lisp create mode 100644 database/run.lisp create mode 100644 database/seeds.lisp create mode 100644 digits.lisp create mode 100644 main.lisp create mode 100644 speedrun.lisp create mode 100644 ui.lisp create mode 100644 util.lisp diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..3c4e808 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +*.db +*.env diff --git a/README.org b/README.org new file mode 100644 index 0000000..c64eadf --- /dev/null +++ b/README.org @@ -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 ~. This will add the category and its splits to the timer's SQLite database. +*** Running +Simply ~sbcl --load main.lisp~ diff --git a/categories/supermetroid-any-kpdr.conf b/categories/supermetroid-any-kpdr.conf new file mode 100644 index 0000000..6c5e6ef --- /dev/null +++ b/categories/supermetroid-any-kpdr.conf @@ -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! diff --git a/config.lisp b/config.lisp new file mode 100644 index 0000000..4fb5bc0 --- /dev/null +++ b/config.lisp @@ -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))) diff --git a/database/category.lisp b/database/category.lisp new file mode 100644 index 0000000..4416331 --- /dev/null +++ b/database/category.lisp @@ -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; diff --git a/database/run.lisp b/database/run.lisp new file mode 100644 index 0000000..30b8342 --- /dev/null +++ b/database/run.lisp @@ -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)))) diff --git a/database/seeds.lisp b/database/seeds.lisp new file mode 100644 index 0000000..769676d --- /dev/null +++ b/database/seeds.lisp @@ -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")) diff --git a/digits.lisp b/digits.lisp new file mode 100644 index 0000000..226bc23 --- /dev/null +++ b/digits.lisp @@ -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 (" ___ " + " / _ \\ " + "| (_) |" + " \\__, |" + " /_/ ")) + (#\. (" " + " " + " " + " _ " + "(_)")) + (#\: (" _ " + "(_)" + " " + " _ " + "(_)")))) diff --git a/main.lisp b/main.lisp new file mode 100644 index 0000000..5efd61e --- /dev/null +++ b/main.lisp @@ -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) diff --git a/speedrun.lisp b/speedrun.lisp new file mode 100644 index 0000000..d872227 --- /dev/null +++ b/speedrun.lisp @@ -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)))) diff --git a/ui.lisp b/ui.lisp new file mode 100644 index 0000000..a4ffb44 --- /dev/null +++ b/ui.lisp @@ -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)))))) diff --git a/util.lisp b/util.lisp new file mode 100644 index 0000000..805e0bc --- /dev/null +++ b/util.lisp @@ -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)))