None of the original commit messages would actually help anyone

12 files changed, 491 insertions, 0 deletions

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 <path-to-config>~. 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)))