d7119e2cc512

Initial commit
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Tue, 15 Nov 2016 23:12:46 +0000
parents
children f7f47291a61a
branches/tags (none)
files .ffignore .hgignore .lispwords Makefile README.markdown cl-chip8.asd package.lisp src/emulator.lisp vendor/make-quickutils.lisp vendor/quickutils-package.lisp vendor/quickutils.lisp

Changes

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/.hgignore	Tue Nov 15 23:12:46 2016 +0000
@@ -0,0 +1,4 @@
+syntax: glob
+
+scratch.lisp
+roms
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Makefile	Tue Nov 15 23:12:46 2016 +0000
@@ -0,0 +1,8 @@
+.PHONY: vendor
+
+# Vendor ----------------------------------------------------------------------
+vendor/quickutils.lisp: vendor/make-quickutils.lisp
+	cd vendor && sbcl --noinform --load make-quickutils.lisp  --eval '(quit)'
+
+vendor: vendor/quickutils.lisp
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/README.markdown	Tue Nov 15 23:12:46 2016 +0000
@@ -0,0 +1,3 @@
+A Chip-8 emulator in Common Lisp.
+
+* **License:** MIT/X11
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/cl-chip8.asd	Tue Nov 15 23:12:46 2016 +0000
@@ -0,0 +1,27 @@
+(asdf:defsystem :cl-chip8
+  :name "chip8"
+  :description "Simple Chip-8 emulator."
+
+  :author "Steve Losh <steve@stevelosh.com>"
+
+  :license "MIT/X11"
+  :version "1.0.0"
+
+  :depends-on (:iterate
+               :losh
+               :cl-arrows
+               :bordeaux-threads
+               :qtools
+               :qtcore
+               :qtgui
+               :qtopengl
+               :cl-opengl)
+
+  :serial t
+  :components ((:module "vendor" :serial t
+                :components ((:file "quickutils-package")
+                             (:file "quickutils")))
+               (:file "package")
+               (:module "src" :serial t
+                :components (#+no (:module "gui" :serial t :components ((:file "main")))
+                             (:file "emulator")))))
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/package.lisp	Tue Nov 15 23:12:46 2016 +0000
@@ -0,0 +1,14 @@
+(defpackage :chip8
+  (:use
+    :cl
+    :losh
+    :iterate
+    :cl-arrows
+    :chip8.quickutils)
+  (:export)
+  (:shadow :bit))
+
+
+(defpackage :chip8.gui
+  (:use :cl+qt :iterate :losh
+    :chip8.quickutils))
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/emulator.lisp	Tue Nov 15 23:12:46 2016 +0000
@@ -0,0 +1,8 @@
+(in-package :chip8)
+
+(setf *print-length* 10)
+(setf *print-base* 10)
+(declaim (optimize (speed 1) (safety 3) (debug 3)))
+; (declaim (optimize (speed 3) (safety 0) (debug 0)))
+
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/vendor/make-quickutils.lisp	Tue Nov 15 23:12:46 2016 +0000
@@ -0,0 +1,19 @@
+(ql:quickload 'quickutil)
+
+(qtlc:save-utils-as
+  "quickutils.lisp"
+  :utilities '(
+
+               :compose
+               :curry
+               :ensure-boolean
+               :ensure-gethash
+               :ensure-list
+               :once-only
+               :rcurry
+               :read-file-into-byte-vector
+               :symb
+               :with-gensyms
+
+               )
+  :package "CHIP8.QUICKUTILS")
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/vendor/quickutils-package.lisp	Tue Nov 15 23:12:46 2016 +0000
@@ -0,0 +1,12 @@
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (find-package "CHIP8.QUICKUTILS")
+    (defpackage "CHIP8.QUICKUTILS"
+      (:documentation "Package that contains Quickutil utility functions.")
+      (:use :cl))))
+
+(in-package "CHIP8.QUICKUTILS")
+
+;; need to define this here so sbcl will shut the hell up about it being
+;; undefined when compiling quickutils.lisp.  computers are trash.
+(defparameter *utilities* nil)
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/vendor/quickutils.lisp	Tue Nov 15 23:12:46 2016 +0000
@@ -0,0 +1,278 @@
+;;;; This file was automatically generated by Quickutil.
+;;;; See http://quickutil.org for details.
+
+;;;; To regenerate:
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :ONCE-ONLY :RCURRY :READ-FILE-INTO-BYTE-VECTOR :SYMB :WITH-GENSYMS) :ensure-package T :package "CHIP8.QUICKUTILS")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (find-package "CHIP8.QUICKUTILS")
+    (defpackage "CHIP8.QUICKUTILS"
+      (:documentation "Package that contains Quickutil utility functions.")
+      (:use #:cl))))
+
+(in-package "CHIP8.QUICKUTILS")
+
+(when (boundp '*utilities*)
+  (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
+                                         :COMPOSE :CURRY :ENSURE-BOOLEAN
+                                         :ENSURE-GETHASH :ENSURE-LIST
+                                         :ONCE-ONLY :RCURRY :WITH-OPEN-FILE*
+                                         :WITH-INPUT-FROM-FILE
+                                         :READ-FILE-INTO-BYTE-VECTOR :MKSTR
+                                         :SYMB :STRING-DESIGNATOR :WITH-GENSYMS))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun make-gensym-list (length &optional (x "G"))
+    "Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`,
+using the second (optional, defaulting to `\"G\"`) argument."
+    (let ((g (if (typep x '(integer 0)) x (string x))))
+      (loop repeat length
+            collect (gensym g))))
+  )                                        ; eval-when
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  ;;; To propagate return type and allow the compiler to eliminate the IF when
+  ;;; it is known if the argument is function or not.
+  (declaim (inline ensure-function))
+
+  (declaim (ftype (function (t) (values function &optional))
+                  ensure-function))
+  (defun ensure-function (function-designator)
+    "Returns the function designated by `function-designator`:
+if `function-designator` is a function, it is returned, otherwise
+it must be a function name and its `fdefinition` is returned."
+    (if (functionp function-designator)
+        function-designator
+        (fdefinition function-designator)))
+  )                                        ; eval-when
+
+  (defun compose (function &rest more-functions)
+    "Returns a function composed of `function` and `more-functions` that applies its ;
+arguments to to each in turn, starting from the rightmost of `more-functions`,
+and then calling the next one with the primary value of the last."
+    (declare (optimize (speed 3) (safety 1) (debug 1)))
+    (reduce (lambda (f g)
+              (let ((f (ensure-function f))
+                    (g (ensure-function g)))
+                (lambda (&rest arguments)
+                  (declare (dynamic-extent arguments))
+                  (funcall f (apply g arguments)))))
+            more-functions
+            :initial-value function))
+
+  (define-compiler-macro compose (function &rest more-functions)
+    (labels ((compose-1 (funs)
+               (if (cdr funs)
+                   `(funcall ,(car funs) ,(compose-1 (cdr funs)))
+                   `(apply ,(car funs) arguments))))
+      (let* ((args (cons function more-functions))
+             (funs (make-gensym-list (length args) "COMPOSE")))
+        `(let ,(loop for f in funs for arg in args
+                     collect `(,f (ensure-function ,arg)))
+           (declare (optimize (speed 3) (safety 1) (debug 1)))
+           (lambda (&rest arguments)
+             (declare (dynamic-extent arguments))
+             ,(compose-1 funs))))))
+  
+
+  (defun curry (function &rest arguments)
+    "Returns a function that applies `arguments` and the arguments
+it is called with to `function`."
+    (declare (optimize (speed 3) (safety 1) (debug 1)))
+    (let ((fn (ensure-function function)))
+      (lambda (&rest more)
+        (declare (dynamic-extent more))
+        ;; Using M-V-C we don't need to append the arguments.
+        (multiple-value-call fn (values-list arguments) (values-list more)))))
+
+  (define-compiler-macro curry (function &rest arguments)
+    (let ((curries (make-gensym-list (length arguments) "CURRY"))
+          (fun (gensym "FUN")))
+      `(let ((,fun (ensure-function ,function))
+             ,@(mapcar #'list curries arguments))
+         (declare (optimize (speed 3) (safety 1) (debug 1)))
+         (lambda (&rest more)
+           (apply ,fun ,@curries more)))))
+  
+
+  (defun ensure-boolean (x)
+    "Convert `x` into a Boolean value."
+    (and x t))
+  
+
+  (defmacro ensure-gethash (key hash-table &optional default)
+    "Like `gethash`, but if `key` is not found in the `hash-table` saves the `default`
+under key before returning it. Secondary return value is true if key was
+already in the table."
+    `(multiple-value-bind (value ok) (gethash ,key ,hash-table)
+       (if ok
+           (values value ok)
+           (values (setf (gethash ,key ,hash-table) ,default) nil))))
+  
+
+  (defun ensure-list (list)
+    "If `list` is a list, it is returned. Otherwise returns the list designated by `list`."
+    (if (listp list)
+        list
+        (list list)))
+  
+
+  (defmacro once-only (specs &body forms)
+    "Evaluates `forms` with symbols specified in `specs` rebound to temporary
+variables, ensuring that each initform is evaluated only once.
+
+Each of `specs` must either be a symbol naming the variable to be rebound, or of
+the form:
+
+    (symbol initform)
+
+Bare symbols in `specs` are equivalent to
+
+    (symbol symbol)
+
+Example:
+
+    (defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
+      (let ((y 0)) (cons1 (incf y))) => (1 . 1)"
+    (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
+          (names-and-forms (mapcar (lambda (spec)
+                                     (etypecase spec
+                                       (list
+                                        (destructuring-bind (name form) spec
+                                          (cons name form)))
+                                       (symbol
+                                        (cons spec spec))))
+                                   specs)))
+      ;; bind in user-macro
+      `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
+              gensyms names-and-forms)
+         ;; bind in final expansion
+         `(let (,,@(mapcar (lambda (g n)
+                             ``(,,g ,,(cdr n)))
+                           gensyms names-and-forms))
+            ;; bind in user-macro
+            ,(let ,(mapcar (lambda (n g) (list (car n) g))
+                    names-and-forms gensyms)
+               ,@forms)))))
+  
+
+  (defun rcurry (function &rest arguments)
+    "Returns a function that applies the arguments it is called
+with and `arguments` to `function`."
+    (declare (optimize (speed 3) (safety 1) (debug 1)))
+    (let ((fn (ensure-function function)))
+      (lambda (&rest more)
+        (declare (dynamic-extent more))
+        (multiple-value-call fn (values-list more) (values-list arguments)))))
+  
+
+  (defmacro with-open-file* ((stream filespec &key direction element-type
+                                                   if-exists if-does-not-exist external-format)
+                             &body body)
+    "Just like `with-open-file`, but `nil` values in the keyword arguments mean to use
+the default value specified for `open`."
+    (once-only (direction element-type if-exists if-does-not-exist external-format)
+      `(with-open-stream
+           (,stream (apply #'open ,filespec
+                           (append
+                            (when ,direction
+                              (list :direction ,direction))
+                            (when ,element-type
+                              (list :element-type ,element-type))
+                            (when ,if-exists
+                              (list :if-exists ,if-exists))
+                            (when ,if-does-not-exist
+                              (list :if-does-not-exist ,if-does-not-exist))
+                            (when ,external-format
+                              (list :external-format ,external-format)))))
+         ,@body)))
+  
+
+  (defmacro with-input-from-file ((stream-name file-name &rest args
+                                                         &key (direction nil direction-p)
+                                                         &allow-other-keys)
+                                  &body body)
+    "Evaluate `body` with `stream-name` to an input stream on the file
+`file-name`. `args` is sent as is to the call to `open` except `external-format`,
+which is only sent to `with-open-file` when it's not `nil`."
+    (declare (ignore direction))
+    (when direction-p
+      (error "Can't specifiy :DIRECTION for WITH-INPUT-FROM-FILE."))
+    `(with-open-file* (,stream-name ,file-name :direction :input ,@args)
+       ,@body))
+  
+
+  (defun read-file-into-byte-vector (pathname)
+    "Read `pathname` into a freshly allocated `(unsigned-byte 8)` vector."
+    (with-input-from-file (stream pathname :element-type '(unsigned-byte 8))
+      (let ((length (file-length stream)))
+        (assert length)
+        (let ((result (make-array length :element-type '(unsigned-byte 8))))
+          (read-sequence result stream)
+          result))))
+  
+
+  (defun mkstr (&rest args)
+    "Receives any number of objects (string, symbol, keyword, char, number), extracts all printed representations, and concatenates them all into one string.
+
+Extracted from _On Lisp_, chapter 4."
+    (with-output-to-string (s)
+      (dolist (a args) (princ a s))))
+  
+
+  (defun symb (&rest args)
+    "Receives any number of objects, concatenates all into one string with `#'mkstr` and converts them to symbol.
+
+Extracted from _On Lisp_, chapter 4.
+
+See also: `symbolicate`"
+    (values (intern (apply #'mkstr args))))
+  
+
+  (deftype string-designator ()
+    "A string designator type. A string designator is either a string, a symbol,
+or a character."
+    `(or symbol string character))
+  
+
+  (defmacro with-gensyms (names &body forms)
+    "Binds each variable named by a symbol in `names` to a unique symbol around
+`forms`. Each of `names` must either be either a symbol, or of the form:
+
+    (symbol string-designator)
+
+Bare symbols appearing in `names` are equivalent to:
+
+    (symbol symbol)
+
+The string-designator is used as the argument to `gensym` when constructing the
+unique symbol the named variable will be bound to."
+    `(let ,(mapcar (lambda (name)
+                     (multiple-value-bind (symbol string)
+                         (etypecase name
+                           (symbol
+                            (values name (symbol-name name)))
+                           ((cons symbol (cons string-designator null))
+                            (values (first name) (string (second name)))))
+                       `(,symbol (gensym ,string))))
+            names)
+       ,@forms))
+
+  (defmacro with-unique-names (names &body forms)
+    "Binds each variable named by a symbol in `names` to a unique symbol around
+`forms`. Each of `names` must either be either a symbol, or of the form:
+
+    (symbol string-designator)
+
+Bare symbols appearing in `names` are equivalent to:
+
+    (symbol symbol)
+
+The string-designator is used as the argument to `gensym` when constructing the
+unique symbol the named variable will be bound to."
+    `(with-gensyms ,names ,@forms))
+  
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (export '(compose curry ensure-boolean ensure-gethash ensure-list once-only
+            rcurry read-file-into-byte-vector symb with-gensyms
+            with-unique-names)))
+
+;;;; END OF quickutils.lisp ;;;;