.gitignore

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

README.markdown

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

categories/sm64-any-16-stars.conf

@@ -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
+

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!

config.lisp

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

database/category.lisp

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

database/run.lisp

@@ -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))))))
+  

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 ("  ___  "
+                " / _ \\ "
+                "| (_) |"
+                " \\__, |"
+                "   /_/ "))
+          (#\. ("   "
+                "   "
+                "   "
+                " _ "
+                "(_)"))
+          (#\: (" _ "
+                "(_)"
+                "   "
+                " _ "
+                "(_)"))))

helper.lisp

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

lispruns.asd

@@ -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"))))

main.lisp

@@ -1,59 +1,156 @@
-(load "helper.lisp")
+;; Migrate database structure
-(load "splits.lisp")
+(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 '())
+(defparameter *lispruns-logo* 
-(defvar done-splits '())
+  '("db      d888888b .d8888. d8888b. d8888b. db    db d8b   db .d8888."
-(defvar last-time-space-pressed 0)
+    "88        `88'   88'  YP 88  `8D 88  `8D 88    88 888o  88 88'  YP"
-(defvar pb 0)
+    "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)
+(defun get-input (prompt &optional (validator 'nonempty-p))
-  (cond
+  (clear-input)
-	((y-or-n-p "Read file")
+  (write-string prompt)
-	  (read-file-of-splits filename)
+  (finish-output)
-	  (setf
+  (let ((input (read-line)))
-	   *splits*
+    (if (ignore-errors (funcall validator input))
-	   (set-column-in-run-from-other-run
+        input
-		2
+        (progn
-		(make-run-of-best-segments *all-splits* 0)
+          (format t "E: Invalid input. Try again.~%")
-		*splits*))
+          (get-input prompt validator)))))
-	  (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)
+;; Options is an alist with the prompt string as the car and the value as the cdr
-  (read-in-splits filename)
+(defun select-option (options)
-  (setf last-time-space-pressed (get-internal-real-time))
+  (let ((i 0))
-  (charms:with-curses ()
+    (loop for x in options
-    (charms:disable-echoing)
+          do
-    (charms:enable-raw-input :interpret-control-characters t)
+             (inc i)
-    (charms:enable-non-blocking-mode charms:*standard-window*)
+             (format t "  [~a] ~a~%" i (car x))))
-	(loop :named driver-loop
+  (let ((user-input (get-input (format nil "Select [~a - ~a] or search: " 1 (length options)))))
-		  :for c := (charms:get-char charms:*standard-window*
+    (if (every #'digit-char-p user-input)
-									 :ignore-error t)
+        ;; Selected by option index
-		  :do (progn
+        (let ((user-integer (parse-integer user-input)))
-				(charms:clear-window charms:*standard-window*)
+          (if (and (>= user-integer 1) (<= user-integer (length options)))
-				(if (null current-split) (return-from driver-loop))
+              (cdr (nth (1- user-integer) options))
-				(charms:write-string-at-point charms:*standard-window* (make-output (push-on-list current-split done-splits) 0 pb) 0 0)
+              (progn
-				(charms:refresh-window charms:*standard-window*)
+                (format t "E: Not a valid selection.~%")
-				(setf current-split (update-split current-split last-time-space-pressed))
+                (select-option options))))
-				(case c
+        ;; Search for user string, either select the one it matches or recursively call select-option on the matched options
-				  ((nil) nil)
+        (let* ((scanner (cl-ppcre:create-scanner user-input :case-insensitive-mode t))
-				  ((#\Space)
+               (filtered
-				   (progn
+                 (remove-if-not
-					 (setf last-time-space-pressed (get-internal-real-time))
+                  (lambda (option) (cl-ppcre:scan scanner (car option)))
-					 (setf done-splits (push-on-list current-split done-splits))
+                  options)))
-					 (setf current-split (car *splits*))
+          (if filtered
-					 (setf *splits* (cdr *splits*))))
+              (case (length filtered)
-				  ((#\q) (return-from driver-loop)))
+                (1 (let ((searched (car filtered)))
-				(sleep 0.01)
+                     (if (y-or-n-p "Use \"~a\"" (car searched))
-				)))
+                         (cdr searched)
-  (setf *all-splits* (cons done-splits *all-splits*))
+                         (select-option options))))
-  (cond ((y-or-n-p "Save?") (with-open-file (output filename :direction :output :if-exists :supersede) (print *all-splits* output))))
+                (t
-  (format nil (format-time (sum-splits done-splits 1))))
+                 (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))

speedrun.lisp

@@ -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))))))
+

splits.lisp

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

text.lisp

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

time.lisp

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

times.txt

@@ -1 +0,0 @@
-

ui.lisp

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

util.lisp

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