├── .gitignore ├── 6502-utils.lisp ├── COPYING ├── asm6502.asd ├── assembler.lisp ├── cycle-counting.lisp ├── hacks ├── audio-test-1.lisp ├── death-star │ ├── chr1.gif │ ├── chr2.gif │ ├── death-star-mapper-0.lisp │ ├── death-star-mmc3.lisp │ └── mask.gif ├── dither1.py ├── dollhouse.lisp ├── fingers_30299.pcm ├── music-demo.lisp ├── music-test.lisp ├── nes-hacklets.lisp ├── nes-hacks.asd ├── nes-test-1.lisp ├── nes-test-2.lisp ├── nsf-test-1.lisp ├── rgbi │ ├── blue.gif │ ├── grayscale-1.gif │ ├── grayscale-2.gif │ ├── grayscale.gif │ ├── grayscale.lisp │ ├── green.gif │ ├── red.gif │ └── rgbi.lisp ├── ryden.gif ├── test1 │ ├── bg0.gif │ ├── spr0.gif │ └── sprite-test.lisp ├── test2.chr └── test2m.chr ├── ichr.asd ├── ichr.lisp ├── nes.lisp ├── nesmus.lisp ├── nesmusic.el ├── nestunes ├── sound-tests.lisp └── steps.lisp └── package.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | #* 3 | *.bin 4 | *.fasl 5 | *.nes 6 | .#* 7 | *.dx64fsl 8 | .DS_Store 9 | -------------------------------------------------------------------------------- /6502-utils.lisp: -------------------------------------------------------------------------------- 1 | (in-package :asm6502-utility) 2 | 3 | (defconstant +nmi-vector+ #xFFFA) 4 | (defconstant +reset-vector+ #xFFFC) 5 | (defconstant +irq-vector+ #xFFFE) 6 | 7 | ;;;; Small utilities 8 | 9 | (defun poke (value address) 10 | (when (typep value '(or integer promise)) 11 | (setf value (imm value))) 12 | (lda value) 13 | (sta (typecase address 14 | ((integer 0 255) (zp address)) 15 | ((or integer promise) (mem address)) 16 | (t address)))) 17 | 18 | ;;; 16-Bit Values / Variables 19 | 20 | (defstruct (wordvar (:constructor wordvar (address))) address) 21 | 22 | (defmethod lsb ((of wordvar)) 23 | (etypecase (wordvar-address of) 24 | ((integer 0 255) (zp (wordvar-address of))) 25 | (t (wordvar-address of)))) 26 | 27 | (defmethod msb ((of wordvar)) 28 | (etypecase (wordvar-address of) 29 | ((integer 0 255) (zp (1+ (wordvar-address of)))) 30 | (promise (mem (delay :msb-of-wordvar ((address (wordvar-address of))) (1+ address)))))) 31 | 32 | (defmethod asm6502::assemble ((opcode (eql 'JMP)) 33 | (of wordvar)) 34 | (asm6502::assemble 'JMP (indirect (wordvar-address of)))) 35 | 36 | (defstruct (wordval (:constructor wordval (value))) value) 37 | 38 | (defmethod lsb ((of wordval)) (imm (lsb (wordval-value of)))) 39 | (defmethod msb ((of wordval)) (imm (msb (wordval-value of)))) 40 | 41 | (defun pushword (value) 42 | (when (typep value '(or integer promise)) 43 | (setf value (wordval value))) 44 | (lda (msb value)) 45 | (pha) 46 | (lda (lsb value)) 47 | (pha)) 48 | 49 | (defgeneric pokeword (value address)) 50 | 51 | (defmethod pokeword (value (address integer)) 52 | (poke (lsb value) address) 53 | (poke (msb value) (1+ address))) 54 | 55 | (defmethod pokeword (value (address promise)) 56 | (pokeword (lsb value) address) 57 | (pokeword (msb value) (delay :pokeword-addr-msb (address) (1+ address)))) 58 | 59 | (defmethod pokeword (value (address wordvar)) 60 | (poke (lsb value) (lsb address)) 61 | (poke (msb value) (msb address))) 62 | 63 | 64 | 65 | ;;;; Control structures 66 | 67 | ;;; Assemble an if-then-else construct. The 'branch-compiler' is invoked 68 | ;;; to generate conditional branch to the else clause. If the 'else-compiler' 69 | ;;; is omitted, the jump following the "then" clause will be optimized away. 70 | 71 | (defgeneric condition-to-branch (condition) 72 | (:documentation "Return a function capable of generating a branch to 73 | the given argument if the condition is *NOT* true." )) 74 | 75 | (defmethod condition-to-branch ((condition symbol)) 76 | (or 77 | (cdr 78 | (assoc condition 79 | '((:positive . bmi) 80 | (:negative . bpl) 81 | (:carry . bcc) 82 | (:no-carry . bcs) 83 | (:zero . bne) 84 | (:not-zero . beq) 85 | (:equal . bne) 86 | (:not-equal . beq) 87 | (:overflow . bvc) 88 | (:no-overflow . bvs)))) 89 | (error "Unknown condition ~A" condition))) 90 | 91 | (defun assemble-if (branch-compiler then-compiler &optional else-compiler) 92 | (let ((else-sym (gensym "ELSE")) 93 | (finally-sym (gensym "FINALLY"))) 94 | (funcall branch-compiler (rel else-sym)) 95 | (funcall then-compiler) 96 | (when else-compiler (jmp (mem (label finally-sym)))) 97 | (set-label else-sym) 98 | (when else-compiler (funcall else-compiler)) 99 | (set-label finally-sym))) 100 | 101 | (defmacro asif (condition &body statements) 102 | (let ((then statements) 103 | (else nil) 104 | (part (position :else statements))) 105 | (when part 106 | (setf then (subseq statements 0 part) 107 | else (subseq statements (1+ part) nil))) 108 | `(assemble-if 109 | ',(condition-to-branch condition) 110 | (lambda () ,@then) 111 | ,(and else `(lambda () ,@else))))) 112 | 113 | (defmacro as/until (condition &body body) 114 | (let ((sym (gensym))) 115 | `(with-label ,sym 116 | ,@body 117 | (funcall (condition-to-branch ',condition) (rel ',sym))))) 118 | 119 | (defmacro with-label (label &body body) 120 | (when (and (listp label) (eql (first label) 'quote)) 121 | (warn "Quoted label name ~A, probably not what you intended" label)) 122 | `(progn (set-label ',label) ,@body)) 123 | 124 | (defmacro procedure (name &body body) 125 | `(progn 126 | (set-label ',name) 127 | (let ((*context* (make-instance 'local-context :parent *context*))) 128 | ,@body))) 129 | 130 | ;;; Delays and timed sections 131 | 132 | (defun emit-delay (delay-cycles) 133 | "Emit a delay of the specified number of CPU cycles. Kills the X register." 134 | (loop while (>= delay-cycles 11) 135 | as iterations = (min 256 (floor (- delay-cycles 5) 5)) 136 | as n = (mod iterations 256) do 137 | #+NIL 138 | (format t "~&Inserting delay loop (~A cycles left), ~A iterations (should burn ~A cycles)~%" 139 | delay-cycles iterations (1+ (* 5 iterations))) 140 | (decf delay-cycles) 141 | (ldx (imm n)) 142 | (unless (<= (lsb *origin*) 253) ; I could work around this.. 143 | (error "Can't assemble a timed loop on a page crossing. Sorry.")) 144 | (as/until :zero (dex)) 145 | (decf delay-cycles (* 5 iterations))) 146 | (when (= 1 delay-cycles) 147 | (error "Not possible to delay for 1 cycle.")) 148 | (when (oddp delay-cycles) 149 | ;;(format t "~&~A cycles to burn -- Inserting LDY instruction.~%" delay-cycles) 150 | (ldx (imm 0)) 151 | (decf delay-cycles 3)) 152 | (loop while (>= delay-cycles 6) do 153 | (ldx (imm 0)) 154 | (ldx (imm 0)) 155 | (decf delay-cycles 6)) 156 | (unless (zerop delay-cycles) 157 | ;;(format t "~&~A cycles to burn -- Inserting ~A NOPs~%" delay-cycles (/ delay-cycles 2)) 158 | (dotimes (i (/ delay-cycles 2)) (nop) (decf delay-cycles 2))) 159 | (assert (zerop delay-cycles))) 160 | 161 | (defmacro timed-section ((cycle-count &key loop) &body body) 162 | `(let ((timed-section-head (set-label (gensym))) 163 | (cycles (counting-cycles ,@body)) 164 | (cycle-count ,cycle-count) 165 | (loop-p ,loop)) 166 | (when loop-p (decf cycle-count 3)) 167 | (unless (> cycle-count 0) 168 | (error "Cycle count for timed section is too small.")) 169 | (unless (>= ,cycle-count cycles) 170 | (error "Timed section takes ~D cycles, which is longer than ~D cycles." 171 | cycles ,cycle-count)) 172 | (emit-delay (- cycle-count cycles)) 173 | (when loop-p (jmp (mem timed-section-head))) 174 | (values))) 175 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012 Andy Hefner 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /asm6502.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem :asm6502 2 | :name "6502 Assembler" 3 | :description "6502 Assembler, and assorted utilities." 4 | :author "Andy Hefner " 5 | :license "MIT-style license" 6 | :version "0.1.0" 7 | :serial t 8 | :components ((:file "package") 9 | (:file "assembler") 10 | (:file "cycle-counting") 11 | (:file "6502-utils") 12 | (:file "nes") 13 | (:file "nesmus"))) 14 | -------------------------------------------------------------------------------- /assembler.lisp: -------------------------------------------------------------------------------- 1 | (in-package :asm6502) 2 | 3 | ;;;; Delayed evaluation 4 | 5 | (defvar *lazy-marker* '#:postponed) 6 | (defstruct promise name fun (value *lazy-marker*)) 7 | 8 | (define-condition resolvable-condition () 9 | ((path :initform nil :initarg :path :accessor path)) 10 | (:report (lambda (condition stream) 11 | (format stream "~A" (path condition))))) 12 | 13 | (defgeneric force (expression &optional force-p) 14 | (:documentation "Forces computing the value of a delayed expression")) 15 | 16 | (defmethod force ((expression number) &optional force-p) 17 | (declare (ignore force-p)) 18 | expression) 19 | 20 | (defparameter *memoize-promises* t 21 | "Controls whether fulfilled promises are cached. Only useful in 22 | abuses of the promise mechanism involving special variables. Don't 23 | do this.") 24 | 25 | (defun set-promise-value (promise value) 26 | (when *memoize-promises* 27 | (setf (promise-value promise) value)) 28 | value) 29 | 30 | (defmethod force ((p promise) &optional (error-p t)) 31 | (if (not (eq (promise-value p) *lazy-marker*)) 32 | (promise-value p) 33 | (handler-case (set-promise-value p (funcall (promise-fun p))) 34 | (resolvable-condition (condition) 35 | (setf (path condition) (cons (promise-name p) (path condition))) 36 | (funcall (if error-p #'error #'signal) condition) 37 | p)))) 38 | 39 | (eval-when (:compile-toplevel :load-toplevel :execute) 40 | (defun parse-binding (spec) 41 | (etypecase spec 42 | (symbol (list spec spec)) 43 | ((cons symbol (cons t null)) spec)))) 44 | 45 | (defmacro forcing (dependencies &body body) 46 | (let ((bindings (mapcar #'parse-binding dependencies))) 47 | `((lambda ,(mapcar #'first bindings) ,@body) 48 | ,@(loop for b in bindings 49 | collect `(force ,(second b)))))) 50 | 51 | (defmacro delay (name dependencies &body body) 52 | `(force 53 | (make-promise :name ,name :fun (lambda () (forcing ,dependencies ,@body))) 54 | nil)) 55 | 56 | (defun resolve-tree (tree) 57 | (etypecase tree 58 | (cons (cons (resolve-tree (car tree)) 59 | (resolve-tree (cdr tree)))) 60 | (null tree) 61 | (integer tree) 62 | (promise (force tree)))) 63 | 64 | ;;;; Bits and bytes 65 | 66 | (defgeneric msb (x) 67 | (:method ((x integer)) (ldb (byte 8 8) x)) 68 | (:method ((value promise)) 69 | (delay :MSB (value) (msb value)))) 70 | 71 | (defgeneric lsb (x) 72 | (:method ((x integer)) (ldb (byte 8 0) x)) 73 | (:method ((value promise)) 74 | (delay :LSB (value) (lsb value)))) 75 | 76 | (defun 8-bit-encodable (x) 77 | (etypecase x 78 | ((integer -128 255) x))) 79 | 80 | (defun signed-octet (x) 81 | (etypecase x 82 | ((integer -128 127) x))) 83 | 84 | (defun encode-byte (byte &optional (name "byte")) 85 | (vector (delay name (byte) (lsb (8-bit-encodable byte))))) 86 | 87 | (defun encode-signed-byte (x &optional (name "signed-byte")) 88 | (vector (delay name (x) (lsb (signed-octet x))))) 89 | 90 | (defun 16-bit-encodable (x) 91 | (etypecase x 92 | ((integer 0 65535) x))) 93 | 94 | (defun encode-word (word &optional (name 'encode-word)) 95 | (vector (delay name (word) (lsb word)) 96 | (delay name (word) (msb word)))) 97 | 98 | (defun join-masks (x y) 99 | (unless (zerop (logand x y)) 100 | (error "Bitmasks ~A and ~A overlap!" x y)) 101 | (logior x y)) 102 | 103 | ;;;; Files 104 | 105 | (defun write-binary-file (filename vector &key 106 | (if-exists :supersede) 107 | (external-format :default) 108 | (element-type '(unsigned-byte 8))) 109 | (with-open-file (out filename 110 | :if-exists if-exists :element-type element-type 111 | :external-format external-format :direction :output) 112 | (write-sequence vector out))) 113 | 114 | (defun binary-file (filename &key (element-type '(unsigned-byte 8))) 115 | (with-open-file (in filename :element-type element-type) 116 | (let ((data (make-array (file-length in)))) 117 | (read-sequence data in) 118 | data))) 119 | 120 | (defsetf binary-file (filename &rest args) (sequence) 121 | `(apply 'write-binary-file ,filename ,sequence ,args) 122 | ;; Doesn't work on CCL: 123 | #+NIL `(write-binary-file ,filename ,sequence ,@args)) 124 | 125 | ;;;; Assembly context protocol 126 | 127 | (defgeneric context-emit (context vector) 128 | (:documentation "Emit a vector of bytes into the assembly context")) 129 | 130 | (defgeneric context-address (context) 131 | (:documentation "Returns current virtual address of the context")) 132 | 133 | (defgeneric (setf context-address) (address context) 134 | (:documentation "Set the current virtual address of the context")) 135 | 136 | (defgeneric context-find-label (context symbol) 137 | (:documentation "Returns the address of a label, or nil.")) 138 | 139 | (defgeneric context-set-label (context symbol &optional address) 140 | (:documentation "Set the address of a label. If not supplied, the current address is used.")) 141 | 142 | (defgeneric context-emit-instruction (context vector) 143 | (:documentation "Emit an instruction into the assembly context. This 144 | is a hint, for contexts which want to handle instructions 145 | specially (e.g. cycle counting).") 146 | (:method (context vector) (context-emit context vector))) 147 | 148 | (defgeneric link (context) 149 | (:documentation "Prepare and return final, assembled output.")) 150 | 151 | ;;; Basic implementation of assembly context 152 | 153 | (defclass symbol-table () 154 | ((symbol-table :initform (make-hash-table :test 'equal)))) 155 | 156 | (defmethod context-find-label ((context symbol-table) symbol) 157 | (with-slots (symbol-table) context 158 | (gethash symbol symbol-table))) 159 | 160 | (defmethod context-set-label ((context symbol-table) symbol 161 | &optional (address (context-address context))) 162 | (with-slots (symbol-table) context 163 | (setf (gethash symbol symbol-table) address))) 164 | 165 | (defclass code-vector () 166 | ((code-vector :initarg :code-vector 167 | :reader context-code-vector 168 | :initform (make-array 0 :adjustable t :fill-pointer t)) 169 | (address :initarg :address :accessor context-address :initform #x8000))) 170 | 171 | (defmethod link ((context code-vector)) 172 | (resolve-vector (context-code-vector context))) 173 | 174 | (defmethod context-emit ((context code-vector) bytes) 175 | (when (> (+ (context-address context) (length bytes)) #x10000) 176 | (warn "Context emit of $~X bytes at $~X will overflow address space" 177 | (length bytes) 178 | (context-address context))) 179 | (map nil (lambda (x) 180 | (unless (typep x '(or (integer 0 255) promise)) 181 | (error "Attempt to emit garbage (~A) at ~X" x (context-address context))) 182 | (vector-push-extend x (context-code-vector context))) 183 | bytes) 184 | (incf (context-address context) (length bytes))) 185 | 186 | (defclass basic-context (code-vector symbol-table) ()) 187 | 188 | (defun resolve-vector (vector) 189 | (let (problems) 190 | (prog1 191 | (map 'vector (lambda (x) 192 | (handler-case (force x t) 193 | (resolvable-condition (c) 194 | (push (path c) problems) 195 | x))) 196 | vector) 197 | (when problems 198 | (error "Unable to resolve output due to the following:~%~A~%" 199 | problems))))) 200 | 201 | ;;; Note that context-code-vector isn't part of the context protocol, 202 | ;;; but defined on basic-contexts. 203 | 204 | (defclass delegate-context () 205 | ((parent :reader context-parent :initarg :parent))) 206 | 207 | (defmethod context-address ((context delegate-context)) 208 | (context-address (context-parent context))) 209 | 210 | (defmethod (setf context-address) (address (context delegate-context)) 211 | (setf (context-address (context-parent context)) address)) 212 | 213 | (defclass delegate-code-vector (delegate-context) ()) 214 | 215 | (defmethod context-emit ((context delegate-code-vector) vector) 216 | (context-emit (context-parent context) vector)) 217 | 218 | (defclass delegate-symbol-lookup (delegate-context) ()) 219 | 220 | (defmethod context-find-label ((context delegate-symbol-lookup) symbol) 221 | (context-find-label (context-parent context) symbol)) 222 | 223 | (defclass delegate-symbol-definition (delegate-context) ()) 224 | 225 | (defmethod context-set-label ((context delegate-symbol-definition) symbol 226 | &optional (address (context-address context))) 227 | (context-set-label (context-parent context) symbol address)) 228 | 229 | (defclass local-symbol-table (delegate-symbol-lookup symbol-table) ()) 230 | 231 | (defmethod context-find-label ((context local-symbol-table) symbol) 232 | (with-slots (symbol-table) context 233 | (gethash symbol symbol-table 234 | (context-find-label (context-parent context) symbol)))) 235 | 236 | ;;; Local context, the base upon which to build local symbol scopes and 237 | ;;; special-purpose contexts. 238 | 239 | (defclass local-context (delegate-code-vector local-symbol-table) ()) 240 | 241 | ;;;; User interface: 242 | 243 | (defvar *context* nil "Current assembly context") 244 | (define-symbol-macro *origin* (context-address *context*)) 245 | 246 | (defun emit (bytes) (context-emit *context* bytes)) 247 | 248 | (defun db (&rest bytes) 249 | (dolist (byte bytes) (context-emit *context* (encode-byte byte)))) 250 | 251 | (defun dw (&rest words) 252 | (dolist (word words) (context-emit *context* (encode-word word)))) 253 | 254 | (defun advance-to (offset &optional (fill-byte #xFF)) 255 | (let ((delta (- offset (context-address *context*)))) 256 | (when (< delta 0) 257 | (error "Cannot advance to ~X, it is less than the current assembly address (~X)" 258 | offset (context-address *context*))) 259 | (context-emit *context* (make-array delta :initial-element fill-byte)))) 260 | 261 | (defun align (alignment &optional (fill-byte #xFF)) 262 | (advance-to (* alignment (ceiling (context-address *context*) alignment)) fill-byte)) 263 | 264 | (defun label (name &key (offset 0) (context *context*)) 265 | (assert (not (null context))) 266 | (delay name (offset) 267 | (+ offset 268 | (or (context-find-label context name) 269 | (error 'resolvable-condition 270 | :path (format nil "Label ~A is undefined" name)))))) 271 | 272 | (defun set-label (name &optional (context *context*)) 273 | (context-set-label context name) 274 | name) 275 | 276 | (defun label-difference (start-name end-name) 277 | (let ((start (label start-name)) 278 | (end (label end-name))) 279 | (delay :label-difference (start end) 280 | (- end start)))) 281 | 282 | ;;;; 283 | ;;;; Definition of Addressing Modes 284 | ;;;; 285 | 286 | (defclass 6502-addressing-mode () ()) 287 | (defclass 6502-mode-with-param (6502-addressing-mode) 288 | ((parameter :reader parameter :initarg :parameter))) 289 | (defclass 6502-mode-param-8 (6502-mode-with-param) ()) 290 | (defclass 6502-mode-param-16 (6502-mode-with-param) ()) 291 | 292 | (defgeneric operand-dwim (object parameter) 293 | (:method ((object 6502-mode-with-param) x) x)) 294 | 295 | ;; define-addrress-mode: Macro to automate generation of addressing 296 | ;; mode classes and constructor functions. 297 | (defmacro define-addressing-mode (name superclass-list) 298 | `(progn 299 | (defclass ,name ,superclass-list ()) 300 | (defgeneric ,name (param)) 301 | (defmethod ,name (param) 302 | (let ((object (make-instance ',name))) 303 | (setf (slot-value object 'parameter) 304 | (operand-dwim object param)) 305 | object)))) 306 | 307 | ;; Implicit address modes are currently specified by passing nil to #'assemble 308 | ;; We consider the accumulator address mode a special case of implicit addressing. 309 | 310 | (defclass zero-page-mode (6502-mode-param-8) ()) ;; Expressions containing an address in the zero page 311 | (defclass absolute-mode (6502-mode-param-16) ()) ;; Expressions containing a 16-bit literal address 312 | 313 | (define-addressing-mode imm (6502-mode-param-8)) ;; Immediate 314 | (define-addressing-mode zp (zero-page-mode)) ;; Zero Page 315 | (define-addressing-mode zpx (zero-page-mode)) ;; Zero Page, X 316 | (define-addressing-mode zpy (zero-page-mode)) ;; Zero Page, Y { for STX/LDX instructions } 317 | (define-addressing-mode idxi (zero-page-mode)) ;; Indexed Indirect ($aa,X) { table of pointers } 318 | (define-addressing-mode indi (zero-page-mode)) ;; Indirect Indexed ($aa),Y { pointer + offset } 319 | (define-addressing-mode mem (absolute-mode)) ;; Absolute Address 320 | (define-addressing-mode abx (absolute-mode)) ;; Absolute, X 321 | (define-addressing-mode aby (absolute-mode)) ;; Absolute, Y { for LDX instruction } 322 | (define-addressing-mode indirect (absolute-mode)) ;; Indirect 323 | 324 | (define-addressing-mode relative (6502-mode-param-8)) ;; PC-Relative offset (for branch instructions) 325 | 326 | (defun rel (label) 327 | (let ((addr (context-address *context*)) 328 | (label (label label))) 329 | (relative (delay :relative (label) (- label addr 2))))) 330 | 331 | ;;; Instruction parameters, according to addressing mode 332 | 333 | (defgeneric parameter-bytes (parameter) 334 | (:documentation "Generate byte vector for instruction parameter")) 335 | 336 | (defmethod parameter-bytes ((x null)) #()) ; Implicit/accumulator operand 337 | (defmethod parameter-bytes ((mode 6502-mode-param-8)) 338 | (encode-byte (parameter mode))) 339 | (defmethod parameter-bytes ((mode 6502-mode-param-16)) 340 | (encode-word (parameter mode))) 341 | (defmethod parameter-bytes ((mode relative)) 342 | (encode-signed-byte (parameter mode))) 343 | 344 | (defmethod parameter-bytes ((mode indirect)) 345 | (encode-word 346 | (delay nil ((address (parameter mode))) 347 | (if (= #xFF (logand address #xFF)) 348 | (error "Indirect jump through ~X tickles 6502 page wraparound bug." address) 349 | address)))) 350 | 351 | ;;;; 352 | ;;;; The 6502 Instruction Set (see http://axis.llx.com/~nparker/a2/opcodes.html) 353 | ;;;; 354 | 355 | (defgeneric assemble (mnemonic parameter) 356 | (:documentation "Assemble an instruction and its parameter, producing a vector of byte values.") 357 | (:method (mnemonic parameter) 358 | (error "Don't know how to assemble instruction ~A ~A" mnemonic parameter))) 359 | 360 | (defgeneric choose-opcode (mnemonic parameter) 361 | (:documentation "Choose the correct opcode for an instruction according to addressing mode") 362 | (:method (mnemonic parameter) 363 | (error "Invalid addressing mode or instruction (~A,~A)" mnemonic parameter))) 364 | 365 | (defmethod assemble ((instruction symbol) parameter) 366 | (concatenate 'vector 367 | (vector (choose-opcode instruction parameter)) 368 | (parameter-bytes parameter))) 369 | 370 | (defmacro def6502 (name encoder &rest args) 371 | `(progn 372 | (defmethod choose-opcode ((instruction (eql ',name)) parameter) 373 | (funcall #',encoder parameter ,@args)) 374 | (defun ,name (&optional operand) 375 | (context-emit-instruction *context* (assemble ',name operand))))) 376 | 377 | (defun invalid-operand-error (instr-description operand) 378 | (error "Invalid operand or addressing mode for ~A: ~A" 379 | (or instr-description "this instruction") 380 | operand)) 381 | 382 | ;;; Group 1: 383 | ;;; ORA AND EOR ADC STA LDA CMP SBC 384 | ;;; (zp,X) 01 21 41 61 81 A1 C1 E1 385 | ;;; zp 05 25 45 65 85 A5 C5 E5 386 | ;;; # 09 29 49 69 A9 C9 E9 387 | ;;; abs 0D 2D 4D 6D 8D AD CD ED 388 | ;;; (zp),Y 11 31 51 71 91 B1 D1 F1 389 | ;;; zp,X 15 35 55 75 95 B5 D5 F5 390 | ;;; abs,Y 19 39 59 79 99 B9 D9 F9 391 | ;;; abs,X 1D 3D 5D 7D 9D BD DD FD 392 | 393 | (defun group-1-addr-code (x) 394 | (typecase x 395 | (idxi #b000) ; (zero page,X) 396 | (zp #b001) ; zero page 397 | (imm #b010) ; #immediate 398 | (mem #b011) ; absolute 399 | (indi #b100) ; (zero page),Y 400 | (zpx #b101) ; zero page,X 401 | (aby #b110) ; absolute,Y 402 | (abx #b111) ; absolute,X 403 | (t (invalid-operand-error nil x)))) 404 | 405 | (defun group-1-asm (parameter opcode) 406 | (join-masks 407 | (join-masks (ash opcode 5) 408 | (ash (group-1-addr-code parameter) 2)) 409 | #b01)) 410 | 411 | (def6502 ORA group-1-asm #b000) 412 | (def6502 ANDA group-1-asm #b001) 413 | (def6502 EOR group-1-asm #b010) 414 | (def6502 ADC group-1-asm #b011) 415 | (def6502 STA group-1-asm #b100) 416 | (def6502 LDA group-1-asm #b101) 417 | (def6502 CMP group-1-asm #b110) 418 | (def6502 SBC group-1-asm #b111) 419 | 420 | (defmethod choose-opcode ((instruction (eql 'sta)) (operand imm)) 421 | ;; One exception: STA with immediate destination makes no sense. 422 | (invalid-operand-error instruction operand)) 423 | 424 | ;;; Group 2: 425 | ;;; ASL ROL LSR ROR STX LDX DEC INC 426 | ;;; # A2 427 | ;;; zp 06 26 46 66 86 A6 C6 E6 428 | ;;; A 0A 2A 4A 6A 429 | ;;; abs 0E 2E 4E 6E 8E AE CE EE 430 | ;;; zp,X/zp,Y 16 36 56 76 96 B6 D6 F6 431 | ;;; abs,X/abs,Y 1E 3E 5E 7E BE DE FE 432 | 433 | (defun group-2/3-addr-code (x types) 434 | (unless (typep x types) (invalid-operand-error nil x)) 435 | (typecase x 436 | (imm #b000) ; #immediate 437 | (zp #b001) ; zero page 438 | (null #b010) ; accumulator 439 | (mem #b011) ; absolute 440 | (zpx #b101) ; zero page,X 441 | (zpy #b101) ; zero page,Y {for STX, LDX} 442 | (abx #b111) ; absolute,X 443 | (aby #b111))) ; absolute,Y {for LDX} 444 | 445 | (defun group-2-asm (parameter opcode &optional (types '(or zp null mem zpx abx))) 446 | (join-masks 447 | (join-masks (ash opcode 5) 448 | (ash (group-2/3-addr-code parameter types) 2)) 449 | #b10)) 450 | 451 | ;; Default set of address modes is suitable for ASL, ROR, LSR, ROR 452 | (def6502 ASL group-2-asm #b000) 453 | (def6502 ROL group-2-asm #b001) 454 | (def6502 LSR group-2-asm #b010) 455 | (def6502 ROR group-2-asm #b011) 456 | (def6502 STX group-2-asm #b100 '(or zp mem zpy)) 457 | (def6502 LDX group-2-asm #b101 '(or imm zp mem zpy aby)) 458 | (def6502 DEC group-2-asm #b110 '(or zp mem zpx abx)) 459 | (def6502 INC group-2-asm #b111 '(or zp mem zpx abx)) 460 | 461 | ;;; Group 3: 462 | ;; BIT JMP JMP() STY LDY CPY CPX 463 | ;; # A0 C0 E0 464 | ;; zp 24 84 A4 C4 E4 465 | ;; abs 2C 4C 6C 8C AC CC EC 466 | ;; zp,X 94 B4 467 | ;; abs,X BC 468 | 469 | (defun group-3-asm (parameter opcode types) 470 | (join-masks 471 | (join-masks (ash opcode 5) 472 | (ash (group-2/3-addr-code parameter types) 2)) 473 | #b00)) 474 | 475 | (def6502 BITA group-3-asm #b001 '(or zp mem)) 476 | (def6502 STY group-3-asm #b100 '(or zp mem zpx)) 477 | (def6502 LDY group-3-asm #b101 '(or imm zp mem zpx abx)) 478 | (def6502 CPY group-3-asm #b110 '(or imm zp mem)) 479 | (def6502 CPX group-3-asm #b111 '(or imm zp mem)) 480 | 481 | ;;; Special case JMP, because the high bits are not fixed. 482 | 483 | (defun asm-jmp (parameter) 484 | (typecase parameter 485 | (mem #x4C) 486 | (indirect #x6C) 487 | (t (invalid-operand-error 'jmp parameter)))) 488 | 489 | (def6502 JMP asm-jmp) 490 | 491 | ;;; Conditional Branches: 492 | 493 | (defun simple-instruction (operand value &optional (type 'null)) 494 | (unless (typep operand type) (invalid-operand-error "simple instruction" operand)) 495 | value) 496 | 497 | ;; The conditional branch instructions all have the form xxy10000. The flag 498 | ;; indicated by xx is compared with y, and the branch is taken if they are equal. 499 | 500 | ;; xx flag 501 | ;; 00 negative 502 | ;; 01 overflow 503 | ;; 10 carry 504 | ;; 11 zero 505 | 506 | ;; This gives the following branches: 507 | (def6502 BPL simple-instruction #x10 '(or imm relative)) 508 | (def6502 BMI simple-instruction #x30 '(or imm relative)) 509 | (def6502 BVC simple-instruction #x50 '(or imm relative)) 510 | (def6502 BVS simple-instruction #x70 '(or imm relative)) 511 | (def6502 BCC simple-instruction #x90 '(or imm relative)) 512 | (def6502 BCS simple-instruction #xB0 '(or imm relative)) 513 | (def6502 BNE simple-instruction #xD0 '(or imm relative)) 514 | (def6502 BEQ simple-instruction #xF0 '(or imm relative)) 515 | 516 | (defvar *branch-instructions* '(BPL BMI BVC BVS BCC BCS BNE BEQ)) 517 | 518 | ;;; Miscellaneous Instructions: 519 | 520 | ;; The remaining instructions are probably best considered simply by listing 521 | ;; them. Here are the interrupt and subroutine instructions: 522 | 523 | (def6502 BRK simple-instruction #x00) 524 | (def6502 JSR simple-instruction #x20 'mem) 525 | (def6502 RTI simple-instruction #x40) 526 | (def6502 RTS simple-instruction #x60) 527 | 528 | ;; (JSR is the only absolute-addressing instruction that doesn't fit the aaabbbcc pattern.) 529 | 530 | ;; Other single-byte instructions: 531 | 532 | ;; PHP PLP PHA PLA DEY TAY INY INX 533 | ;; 08 28 48 68 88 A8 C8 E8 534 | 535 | ;; CLC SEC CLI SEI TYA CLV CLD SED 536 | ;; 18 38 58 78 98 B8 D8 F8 537 | 538 | ;; TXA TXS TAX TSX DEX NOP 539 | ;; 8A 9A AA BA CA EA 540 | 541 | (def6502 PHP simple-instruction #x08) 542 | (def6502 PLP simple-instruction #x28) 543 | (def6502 PHA simple-instruction #x48) 544 | (def6502 PLA simple-instruction #x68) 545 | (def6502 DEY simple-instruction #x88) 546 | (def6502 TAY simple-instruction #xA8) 547 | (def6502 INY simple-instruction #xC8) 548 | (def6502 INX simple-instruction #xE8) 549 | 550 | (def6502 CLC simple-instruction #x18) 551 | (def6502 SEC simple-instruction #x38) 552 | (def6502 CLI simple-instruction #x58) 553 | (def6502 SEI simple-instruction #x78) 554 | (def6502 TYA simple-instruction #x98) 555 | (def6502 CLV simple-instruction #xB8) 556 | (def6502 CLD simple-instruction #xD8) 557 | (def6502 SED simple-instruction #xF8) 558 | 559 | (def6502 TXA simple-instruction #x8A) 560 | (def6502 TXS simple-instruction #x9A) 561 | (def6502 TAX simple-instruction #xAA) 562 | (def6502 TSX simple-instruction #xBA) 563 | (def6502 DEX simple-instruction #xCA) 564 | (def6502 NOP simple-instruction #xEA) 565 | 566 | ;;;; Syntactic sugar 567 | 568 | ;;; For absolute and absolute indexed modes, resolve labels 569 | ;;; automatically. Permit both symbols and lists (compared under 570 | ;;; EQUAL) as labels. 571 | (defmethod operand-dwim ((op absolute-mode) (parameter symbol)) (label parameter)) 572 | (defmethod operand-dwim ((op absolute-mode) (parameter cons)) (label parameter)) 573 | 574 | ;;; For the JSR instruction, accept a label directly as the parameter, 575 | ;;; because there's only one addressing mode. 576 | (defmethod assemble ((mnemonic (eql 'JSR)) (parameter symbol)) 577 | (assemble mnemonic (mem (label parameter)))) 578 | 579 | (defmethod assemble ((mnemonic (eql 'JSR)) (parameter cons)) 580 | (assemble mnemonic (mem (label parameter)))) 581 | 582 | ;;; Similarly for branch instructions.. 583 | (macrolet ((branch (mnemonic) 584 | `(defmethod assemble ((mnemonic (eql ',mnemonic)) (parameter symbol)) 585 | (assemble mnemonic (rel parameter))))) 586 | (branch BPL) 587 | (branch BMI) 588 | (branch BVC) 589 | (branch BVS) 590 | (branch BCC) 591 | (branch BCS) 592 | (branch BNE) 593 | (branch BEQ)) 594 | -------------------------------------------------------------------------------- /cycle-counting.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Cycle-counting mode for 6502 assembler 2 | 3 | (in-package :asm6502) 4 | 5 | (defparameter *cycle-count* 6 | #(7 6 NIL NIL NIL 3 5 NIL 3 2 2 NIL NIL 4 6 NIL 4 5 NIL NIL NIL 4 6 NIL 2 7 | 4 NIL NIL NIL NIL 7 NIL 6 6 NIL NIL 3 3 5 NIL 4 2 2 NIL 4 4 6 NIL 2 5 8 | NIL NIL NIL 4 6 NIL 2 4 NIL NIL NIL 4 7 NIL 4 6 NIL NIL NIL 3 5 NIL 3 2 9 | 2 NIL 3 6 6 NIL 2 5 NIL NIL NIL 4 6 NIL 2 4 NIL NIL NIL 4 7 NIL 6 6 NIL 10 | NIL NIL 3 5 NIL 4 2 2 NIL 5 NIL 6 NIL 2 5 NIL NIL NIL 4 6 NIL 2 4 NIL 11 | NIL NIL 4 7 NIL NIL 6 NIL NIL 3 3 3 NIL 2 NIL 2 NIL 4 4 4 NIL 2 6 NIL 12 | NIL 4 4 4 NIL 2 5 2 NIL NIL 5 NIL NIL 2 6 2 NIL 3 3 3 NIL 2 2 2 NIL 4 4 13 | 4 NIL 2 5 NIL NIL 4 4 4 NIL 2 4 2 NIL 4 4 4 NIL 2 6 NIL NIL 3 3 5 NIL 2 14 | 2 2 NIL 4 4 6 NIL 2 5 NIL NIL NIL 4 6 NIL 2 4 NIL NIL NIL 4 7 NIL 2 6 15 | NIL NIL 3 3 5 NIL 2 2 2 NIL 4 4 6 NIL 2 5 NIL NIL NIL 4 6 NIL 2 4 NIL 16 | NIL NIL 4 7 NIL)) 17 | 18 | (defparameter *variable-timing* 19 | #(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL T NIL 20 | NIL NIL NIL NIL NIL NIL NIL T NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL 21 | NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL T NIL NIL NIL NIL NIL 22 | NIL NIL NIL T NIL NIL NIL T NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL 23 | NIL NIL NIL NIL NIL NIL NIL T T NIL NIL NIL NIL NIL NIL NIL T NIL NIL 24 | NIL T NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL 25 | NIL NIL T T NIL NIL NIL NIL NIL NIL NIL T NIL NIL NIL T NIL NIL NIL NIL 26 | NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL T NIL NIL NIL 27 | NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL 28 | NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL T T NIL NIL NIL NIL NIL NIL NIL 29 | T NIL NIL T T T NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL 30 | NIL NIL NIL T T NIL NIL NIL NIL NIL NIL NIL T NIL NIL NIL T NIL NIL NIL 31 | NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL T NIL NIL 32 | NIL NIL NIL NIL NIL NIL T NIL NIL NIL T NIL NIL) ) 33 | 34 | (defun opcode-cycles (opcode) 35 | "Determine the number of cycles required to execute an 36 | opcode. Returns two values: the number of cycles, and a boolean value 37 | which is T if the opcode may take a variable number of cycles to 38 | execute. The cycles table is not complete; if the number of cycles is 39 | unknown, the first value is NIL and the second T." 40 | (if (aref *cycle-count* opcode) 41 | (values (aref *cycle-count* opcode) 42 | (aref *variable-timing* opcode)) 43 | (values nil t))) 44 | 45 | ;;; You'd think this would be sufficient to let you count cycles even 46 | ;;; in nested non-cycle-counting context, but sorry, no. 47 | (defgeneric context-note-cycles (context num-cycles) 48 | (:method (c n) (declare (ignore c n))) 49 | (:method ((context delegate-context) num-cycles) 50 | (context-note-cycles (context-parent context) num-cycles))) 51 | 52 | (defclass cycle-counting-context (delegate-code-vector 53 | delegate-symbol-lookup) 54 | ((cycle-count :initform 0 :accessor cycle-count :initarg :cycle-count) 55 | (precise-p :initform t :accessor precise-p :initarg :precise-p))) 56 | 57 | (defmethod context-note-cycles ((context cycle-counting-context) num-cycles) 58 | (incf (cycle-count context) num-cycles)) 59 | 60 | (defmethod context-emit-instruction ((context cycle-counting-context) vector) 61 | (multiple-value-bind (cycles variable) (opcode-cycles (aref vector 0)) 62 | (when variable (setf (precise-p context) nil)) 63 | (if cycles 64 | (context-note-cycles context cycles) 65 | (warn "Don't know number of cycles for opcode ~X" (aref vector 0))) 66 | (call-next-method))) 67 | 68 | (defmacro counting-cycles (&body body) 69 | `(let ((*context* (make-instance 'cycle-counting-context :parent *context*))) 70 | ,@body 71 | (cycle-count *context*))) 72 | 73 | -------------------------------------------------------------------------------- /hacks/audio-test-1.lisp: -------------------------------------------------------------------------------- 1 | ;;;; NES audio test: Output a saw waveform through the DAC from a 2 | ;;;; timed loop. 3 | 4 | (defpackage :audio-test-1 5 | (:use :common-lisp :6502 :6502-modes :asm6502 :asm6502-utility :asm6502-nes)) 6 | 7 | (in-package :audio-test-1) 8 | 9 | (defvar *path* #.*compile-file-truename*) 10 | 11 | (defmacro program ((filename &rest rom-args) 12 | &body body) 13 | `(let* ((*context* (make-instance 'basic-context :address #xC000))) 14 | ,@body 15 | (setf (binary-file "/tmp/prg.bin") (link *context*)) 16 | (write-ines ,filename (link *context*) ,@rom-args))) 17 | 18 | (program ("/tmp/audio-test-1.nes") 19 | (advance-to #xE000) ; Put everything in the last bank. 20 | (with-label nmi (rti)) 21 | (with-label irq (rti)) 22 | 23 | (with-label reset 24 | ;; Initialize registers. 25 | (poke 0 +ppu-cr1+) ; Disable NMI 26 | (poke 0 +ppu-cr2+) ; Disable display 27 | (poke 0 +papu-control+) ; Silence audio 28 | 29 | (lda (imm 0)) 30 | 31 | (with-label :saw 32 | (let* ((inner-cycles 33 | (counting-cycles 34 | ;; Square wave: 35 | ;;(sta (mem +dmc-dac+)) 36 | ;;(eor (imm 32)) 37 | ;; Saw wave: 38 | (sty (mem +dmc-dac+)) 39 | (iny) 40 | ;; Add 3 extra cycles for the jump at the bottom of the loop: 41 | (context-note-cycles *context* 3) 42 | #+NIL (jmp (mem :saw)))) 43 | (clock +ntsc-clock-rate+) 44 | (freq 440.0) 45 | (wave-detail 128) 46 | (loop-cycles (round clock (* wave-detail freq))) 47 | (delay-cycles (- loop-cycles inner-cycles))) 48 | 49 | (format t "~&Target frequency: ~A~%Target cycles: ~A~%" freq loop-cycles) 50 | (format t "~&Need to delay for ~A cycles~%Actual frequency: ~A" 51 | delay-cycles (/ clock loop-cycles wave-detail)) 52 | 53 | (emit-delay delay-cycles) 54 | (jmp (mem :saw)))) 55 | 56 | ;; Halt in an infinite loop. 57 | (jmp (mem *origin*))) 58 | 59 | ;; Interrupt vectors 60 | (advance-to +nmi-vector+) 61 | (dw (label 'nmi)) 62 | (dw (label 'reset)) 63 | (dw (label 'irq))) 64 | -------------------------------------------------------------------------------- /hacks/death-star/chr1.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ahefner/asm6502/802daae092f8ab2c50eb469497ee03b30474f2a7/hacks/death-star/chr1.gif -------------------------------------------------------------------------------- /hacks/death-star/chr2.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ahefner/asm6502/802daae092f8ab2c50eb469497ee03b30474f2a7/hacks/death-star/chr2.gif -------------------------------------------------------------------------------- /hacks/death-star/death-star-mapper-0.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage :death-star 3 | (:use :common-lisp :6502 :6502-modes :asm6502 :asm6502-utility :asm6502-nes)) 4 | 5 | (in-package :death-star) 6 | 7 | (defvar *path* #.(truename *compile-file-pathname*)) 8 | 9 | (let ((*context* (make-instance 'basic-context :address #x8000)) 10 | (*default-pathname-defaults* *path*) 11 | (vblank-flag (zp 16))) 12 | 13 | ;; Entry point, machine init 14 | (set-label 'reset) 15 | (sei) 16 | (cld) 17 | (poke #x40 +papu-irq-ctrl+) ; Disable APU frame IRQ 18 | (ldx (imm #xFF)) ; Init stack pointer 19 | (txs) 20 | (poke #b00000000 +ppu-cr1+) ; Disable NMI 21 | (poke #b00000000 +ppu-cr2+) ; Disable rendering 22 | (poke #b00000000 +dmc-control+) 23 | 24 | (bita (mem +ppu-status+)) ; Clear vblank flag 25 | (as/until :negative ; Loop until high (vblank) bit set 26 | (bita (mem +ppu-status+))) 27 | 28 | ;; Build empty sprite table at $0200 29 | (lda (imm #xFF)) 30 | (ldx (imm 0)) 31 | (as/until :zero 32 | (sta (abx #x0200)) 33 | (inx)) 34 | 35 | ;; Kill time while PPU warms up.. 36 | (ldy (imm 128)) 37 | (ldx (imm 0)) 38 | (as/until :zero 39 | (as/until :zero 40 | (dex)) 41 | (dey)) 42 | 43 | ;;; -- PPU should be ready now.. build the screen contents -- 44 | 45 | (bita (mem +ppu-status+)) ; Wait for vblank again 46 | (as/until :negative 47 | (bita (mem +ppu-status+))) 48 | 49 | 50 | ;; Program palette 51 | (ppuaddr #x3F00) 52 | (loop repeat 4 do 53 | (poke #x0F +vram-io+) 54 | (poke #x2D +vram-io+) 55 | (poke #x00 +vram-io+) 56 | (poke #x3D +vram-io+)) 57 | 58 | ;; Clear nametable $2000 59 | (ppuaddr #x2000) 60 | (lda (imm 255)) ;tile # to clear nametable to 61 | (ldy (imm 30)) ; Y counts down 30 rows 62 | (as/until :zero 63 | (ldx (imm 32)) ; X counts down 32 columns 64 | (as/until :zero 65 | (sta (mem +vram-io+)) 66 | (dex)) 67 | (dey)) 68 | ;; Clear attribute table 69 | (ldx (imm 64)) 70 | (lda (imm 0)) ; First BG palette 71 | (as/until :zero 72 | (sta (mem +vram-io+))) 73 | 74 | ;; Display character rom 75 | (ldx (imm 0)) ; X counts char # from 0 upto 255 76 | (as/until :zero 77 | (txa) ; If lower 4-bits of char # are zero, 78 | (anda (imm #x0F)) ; set PPU addr to new line 79 | (asif :zero ; .. 80 | (txa) ; upper-left is #x2108 81 | (asl) ; A = 32*line (line = top 4 bits of X) 82 | (lda (imm 0)) ; (doing 16-bit addition of line*32 + #x2108) 83 | (adc (imm #x21)) ; carry into MSB 84 | (sta (mem +vram-addr+)) 85 | (txa) ; Compute line*32 again.. 86 | (asl) ; 87 | (clc) ; 88 | (adc (imm 8)) ; Compute LSB of final address 89 | (sta (mem +vram-addr+))) 90 | (stx (mem +vram-io+)) 91 | (inx)) 92 | 93 | ;; Turn the screen back on 94 | (poke #b10000000 +ppu-cr1+) ; Enable NMI 95 | (jsr 'wait-vblank) 96 | (jsr 'wait-vblank) 97 | 98 | (poke 0 +vram-scroll+) 99 | (sta (mem +vram-scroll+)) 100 | (ppuaddr #x2000) 101 | (poke #xE8 +ppu-cr2+) ; BG visible, SPR off, darken screen 102 | 103 | 104 | (with-label :loop 105 | ;; Even frames: 106 | (jsr 'wait-vblank) 107 | (poke #b10000000 +ppu-cr1+) ; Background pattern table $0000 108 | 109 | ;; Odd frames: 110 | (jsr 'wait-vblank) 111 | (poke #b10010000 +ppu-cr1+) ; Background pattern table $1000 112 | 113 | (jmp (mem :loop))) 114 | 115 | (jmp (mem *origin*)) 116 | 117 | (procedure wait-vblank 118 | (lda (imm 0)) 119 | (sta vblank-flag) 120 | (as/until :not-zero 121 | (lda vblank-flag)) 122 | (rts)) 123 | 124 | ;; Interrupt handlers 125 | (procedure vblank-handler 126 | (inc vblank-flag) 127 | (rti)) 128 | 129 | (procedure brk-handler 130 | (rti)) 131 | 132 | ;; Interrupt vectors 133 | (advance-to +nmi-vector+) 134 | (dw (label 'vblank-handler)) 135 | (dw (label 'reset)) 136 | (dw (label 'brk-handler)) 137 | 138 | ;; Generate output file: 139 | (write-ines "/tmp/deathstar-0.nes" 140 | (link *context*) 141 | :chr (concatenate 'vector 142 | (ichr:encode-gif "chr1.gif") 143 | (ichr:encode-gif "chr2.gif")))) 144 | -------------------------------------------------------------------------------- /hacks/death-star/death-star-mmc3.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage :death-star 3 | (:use :common-lisp :6502 :6502-modes :asm6502 :asm6502-utility :asm6502-nes)) 4 | 5 | (in-package :death-star) 6 | 7 | (defvar *path* #.*compile-file-pathname*) 8 | 9 | (defparameter *mmc3-bank-config* 0 10 | "Used for upper bits of writes to $8000 via MMC3-BANK function") 11 | 12 | (defun mmc3-bank (bank value) 13 | (poke (logior *mmc3-bank-config* bank) #x8000) 14 | (poke value #x8001)) 15 | 16 | (let* ((*context* (make-instance 'basic-context :address #x8000)) 17 | (image-x-offset 64) 18 | (image-y-offset 64) 19 | (vblank-flag (zp #x10)) 20 | ;; (tmp-ptr #x20) 21 | ;; (tmp-ptr-lsb (zp tmp-ptr)) 22 | ;; (tmp-ptr-msb (zp (1+ tmp-ptr))) 23 | (tmp-mask-min (zp #x22)) 24 | (tmp-mask-max (zp #x23)) 25 | (tmp-x (zp #x24)) 26 | (tmp-y (zp #x25)) 27 | (sprites #x0200) 28 | (sprite-y (+ sprites 0)) 29 | (sprite-tile (+ sprites 1)) 30 | (sprite-attr (+ sprites 2)) 31 | (sprite-x (+ sprites 3)) 32 | (x-table #x0300) 33 | (y-table #x0340) 34 | (z-table #x3080)) 35 | 36 | ;; --- ENTRY POINT (assemble in last PRG bank) --- 37 | (advance-to #xE000) 38 | (set-label 'reset) 39 | 40 | (sei) 41 | (cld) 42 | (poke #x40 +papu-irq-ctrl+) ; Disable APU frame IRQ 43 | (ldx (imm #xFF)) ; Init stack pointer 44 | (txs) 45 | (poke #b00000000 +ppu-cr1+) ; Disable NMI 46 | (poke #b00000000 +ppu-cr2+) ; Disable rendering 47 | (poke #b00000000 +dmc-control+) 48 | 49 | (bita (mem +ppu-status+)) ; Clear vblank flag 50 | (as/until :negative ; Loop until high (vblank) bit set 51 | (bita (mem +ppu-status+))) 52 | 53 | ;; Build empty sprite table at $0200 54 | (lda (imm 0)) 55 | (ldx (imm 0)) 56 | (as/until :zero 57 | (sta (abx #x0200)) 58 | (inx)) 59 | 60 | ;; Program sprite attributes 61 | (lda (imm #x20)) ; Sprite attribute: Background priority 62 | (as/until :zero 63 | ;; (sta (abx sprite-attr)) 64 | (inx) 65 | (inx) 66 | (inx) 67 | (inx)) 68 | 69 | ;; Randomize initial star positions (temporary..) 70 | (dotimes (index 64) 71 | (poke (random 256) (+ x-table index)) 72 | (poke (random 256) (+ y-table index))) 73 | 74 | ;; Kill time while PPU warms up.. 75 | (ldy (imm 128)) 76 | (ldx (imm 0)) 77 | (as/until :zero 78 | (as/until :zero 79 | (dex)) 80 | (dey)) 81 | 82 | ;;; MMC3 init 83 | (mmc3-bank 0 0) ; PPU $0000 84 | (mmc3-bank 1 2) ; PPU $0800 85 | (mmc3-bank 2 15) ; PPU $1000 86 | (mmc3-bank 3 15) ; PPU $1400 87 | (mmc3-bank 4 15) ; PPU $1800 88 | (mmc3-bank 5 15) ; PPU $1C00 89 | (mmc3-bank 6 0) ; CPU $8000 90 | (mmc3-bank 7 1) ; CPU $A000 91 | (poke 0 #xE000) ; Disable IRQ 92 | 93 | ;;; -- PPU should be ready now.. build the screen contents -- 94 | 95 | (bita (mem +ppu-status+)) ; Wait for vblank again 96 | (as/until :negative 97 | (bita (mem +ppu-status+))) 98 | 99 | ;; Program palette 100 | (ppuaddr #x3F00) 101 | (ldy (imm 8)) 102 | (as/until :zero 103 | (poke #x0F +vram-io+) 104 | (poke #x2D +vram-io+) 105 | (poke #x00 +vram-io+) 106 | (poke #x3D +vram-io+) 107 | (dey)) 108 | 109 | ;; Clear nametable $2000 110 | (ppuaddr #x2000) 111 | (lda (imm 255)) ;tile # to clear nametable to 112 | (ldy (imm 30)) ; Y counts down 30 rows 113 | (as/until :zero 114 | (ldx (imm 32)) ; X counts down 32 columns 115 | (as/until :zero 116 | (sta (mem +vram-io+)) 117 | (dex)) 118 | (dey)) 119 | 120 | ;; Clear attribute table 121 | (ldx (imm 64)) 122 | (lda (imm 0)) ; First BG palette 123 | (as/until :zero 124 | (sta (mem +vram-io+))) 125 | 126 | ;; Display character rom 127 | (ldx (imm 0)) ; X counts char # from 0 upto 255 128 | (as/until :zero 129 | (txa) ; If lower 4-bits of char # are zero, 130 | (anda (imm #x0F)) ; set PPU addr to new line 131 | (asif :zero ; .. 132 | (txa) ; upper-left is #x2108 133 | (asl) ; A = 32*line (line = top 4 bits of X) 134 | (lda (imm 0)) ; (doing 16-bit addition of line*32 + #x2108) 135 | (adc (imm #x21)) ; carry into MSB 136 | (sta (mem +vram-addr+)) 137 | (txa) ; Compute line*32 again.. 138 | (asl) ; 139 | (clc) ; 140 | (adc (imm 8)) ; Compute LSB of final address 141 | (sta (mem +vram-addr+))) 142 | (stx (mem +vram-io+)) 143 | (inx)) 144 | 145 | ;; CHR contents is mostly 1:1 with the screen image, but zero out 146 | ;; the couple characters used for stars: 147 | (ppuaddr #x2108) 148 | (lda (imm 4)) ; Should be empty.. 149 | (sta (mem +vram-io+)) 150 | 151 | ;; Turn the screen back on 152 | (poke #b10000000 +ppu-cr1+) ; NMI ON, BG CHR $0000, SPR CHR $0000 153 | (jsr 'wait-vblank) 154 | (jsr 'wait-vblank) 155 | 156 | (poke 0 +vram-scroll+) 157 | (sta (mem +vram-scroll+)) 158 | (ppuaddr #x2000) 159 | (poke #xF8 +ppu-cr2+) ; BG visible, SPR visible, dim screen 160 | 161 | (with-label :loop 162 | 163 | ;; Even frames: 164 | (jsr 'build-sprites) 165 | (jsr 'wait-vblank) 166 | (ppuaddr 0) 167 | (poke 0 +vram-scroll+) 168 | (lda (imm (msb sprites))) ; Transfer sprites 169 | (sta (mem +sprite-dma+)) 170 | (mmc3-bank 0 0) ; PPU $0000 171 | (mmc3-bank 1 2) ; PPU $0800 172 | (poke #b10000000 +ppu-cr1+) ; NMI ON, BG CHR $0000, SPR CHR $0000 173 | 174 | ;; Odd frames: 175 | ;;(jsr 'build-sprites) 176 | (jsr 'wait-vblank) 177 | (ppuaddr 0) 178 | (poke 0 +vram-scroll+) 179 | (lda (imm (msb sprites))) ; Transfer sprites 180 | (sta (mem +sprite-dma+)) 181 | (mmc3-bank 0 4) ; PPU $0000 182 | (mmc3-bank 1 6) ; PPU $0800 183 | (poke #b10000000 +ppu-cr1+) ; NMI ON, BG CHR $0000, SPR CHR $0000 184 | 185 | (jmp (mem :loop))) 186 | 187 | (jmp (mem *origin*)) 188 | 189 | ;; ------------------------------------------------------------ 190 | 191 | (procedure build-sprites 192 | (ldx (imm 63)) 193 | ;; Loop through sprites. X counts sprite number down from 63 to 0. 194 | (as/until :negative 195 | (txa) ; Y=X*4 196 | (asl) 197 | (asl) 198 | (tay) 199 | 200 | ;; Update sprite X/Y coordinates 201 | (lda (abx y-table)) 202 | (sta (aby sprite-y)) 203 | (sta tmp-y) 204 | 205 | (lda (abx x-table)) 206 | (sta (aby sprite-x)) 207 | (sta tmp-x) 208 | (inc (abx x-table)) 209 | 210 | (txa) ; Save X register on stack. 211 | (pha) 212 | 213 | (lda tmp-y) 214 | (tax) 215 | (lda (abx 'mask-max)) 216 | (sta tmp-mask-max) 217 | (lda (abx 'mask-min)) 218 | (sec) 219 | (cmp tmp-x) 220 | (asif :no-carry 221 | (lda tmp-x) 222 | (cmp tmp-mask-max) 223 | (asif :no-carry 224 | (lda (imm 1)) 225 | :else 226 | (lda (imm 0))) 227 | :else 228 | (lda (imm 0))) 229 | (sta (aby sprite-tile)) 230 | 231 | (pla) ; Restore X register 232 | (tax) 233 | (dex)) 234 | (rts)) 235 | 236 | (defun gen-mask-pairs (matrix) 237 | (loop 238 | with width = (array-dimension matrix 1) 239 | with height = (array-dimension matrix 0) 240 | for y below height 241 | collect (list (loop for x from 0 below width 242 | when (not (zerop (aref matrix y x))) 243 | return x 244 | finally (return nil)) 245 | (loop for x from (1- width) above 0 246 | when (not (zerop (aref matrix y x))) 247 | return x 248 | finally (return nil))))) 249 | 250 | ;;; Emit table of pixel spans obscured by foreground image - Sprite 251 | ;;; priority isn't sufficient to keep sprites behind the image 252 | ;;; because there are black pixels in the image. 253 | (let ((spans (gen-mask-pairs (ichr:read-gif "mask.gif")))) 254 | (assert (= 128 (length spans))) 255 | 256 | (set-label 'mask-min) 257 | (loop repeat 64 do (db 255)) 258 | (loop for span in spans 259 | as tmp = (first span) 260 | ;; Offset coordinate by -1, easier than changing comparison from <= to < 261 | do (db (if tmp (+ image-x-offset -1 tmp) 255))) 262 | (loop repeat 64 do (db 255)) 263 | 264 | (set-label 'mask-max) 265 | (loop repeat 64 do (db 255)) 266 | (loop for span in spans 267 | as tmp = (second span) 268 | do (db (if tmp (+ image-x-offset tmp) 0))) 269 | (loop repeat 64 do (db 255))) 270 | 271 | (procedure wait-vblank 272 | (lda (imm 0)) 273 | (sta vblank-flag) 274 | (as/until :not-zero 275 | (lda vblank-flag)) 276 | (rts)) 277 | 278 | ;; Interrupt handlers 279 | (procedure vblank-handler 280 | (inc vblank-flag) 281 | (rti)) 282 | 283 | (procedure irq-handler 284 | (poke 0 #xE000) ; ACK / Disable IRQ 285 | (rti)) 286 | 287 | ;; Interrupt vectors 288 | (advance-to +nmi-vector+) 289 | (dw (label 'vblank-handler)) 290 | (dw (label 'reset)) 291 | (dw (label 'irq-handler)) 292 | 293 | ;; Generate output file (TNROM, 32K PRG / 16K CHR) 294 | (write-ines "/tmp/deathstar.nes" 295 | (link *context*) 296 | :mapper 4 297 | :chr (concatenate 'vector 298 | (ichr:encode-gif "chr1.gif") 299 | (ichr:encode-gif "chr2.gif") 300 | (ichr:encode-gif "chr1.gif") 301 | (ichr:encode-gif "chr2.gif")))) 302 | 303 | -------------------------------------------------------------------------------- /hacks/death-star/mask.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ahefner/asm6502/802daae092f8ab2c50eb469497ee03b30474f2a7/hacks/death-star/mask.gif -------------------------------------------------------------------------------- /hacks/dither1.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | 3 | # Pixel art dither script for GIMP 4 | # Author: ahefner@gmail.com 5 | 6 | import math 7 | from gimpfu import * 8 | from array import array 9 | 10 | def python_8bit_dither(img, srclayer, x_offset, y_offset, x_chk, y_chk): 11 | pdb.gimp_image_undo_group_start(img) 12 | try: 13 | layer = srclayer.copy() 14 | img.add_layer(layer, 0) 15 | width = layer.width 16 | height = layer.height 17 | 18 | rgn = layer.get_pixel_rgn(0, 0, width, height, TRUE, FALSE) 19 | src_pixels = array("B", rgn[0:width, 0:height]) 20 | 21 | # cmbytes, cmdata = pdb.gimp_image_get_colormap(img) 22 | # colors = cmbytes / 3 23 | # pdb.gimp_message(str(cmdata)) 24 | 25 | i = 0 26 | ph = 0 27 | for y in range(height): 28 | ph = (y*y_chk + y_offset) & 1 29 | if (not y_chk): ph = 0 30 | for x in range(width): 31 | c = src_pixels[i] 32 | if (c & 1): 33 | c = c-1 if (((ph + x_offset) & 1) == 0) else c+1 34 | if (c > 255): 35 | c = 255 36 | src_pixels[i] = c 37 | if x_chk: ph = ph ^ 1 38 | i = i + 1 39 | 40 | rgn[0:width, 0:height] = src_pixels.tostring() 41 | 42 | layer.flush() 43 | layer.update(0,0,width,height) 44 | pdb.gimp_image_undo_group_end(img) 45 | 46 | except Exception, err: 47 | pdb.gimp_message("ERR: " + str(err)) 48 | pdb.gimp_image_undo_group_end(img) 49 | 50 | register( 51 | "python_fu_dither", 52 | "Dither odd colors in an indexed-color image", 53 | "Dither odd colors in an indexed-color image", 54 | "Andy Hefner", 55 | "Andy Hefner", 56 | "2013", 57 | "/Filters/Hefner/8-Bit Dither Helper", 58 | "INDEXED", 59 | [ 60 | (PF_TOGGLE, "x_offset", "Pattern X offset", False), 61 | (PF_TOGGLE, "y_offset", "Pattern Y offset", False), 62 | (PF_TOGGLE, "x_chk", "X checkerboard", True), 63 | (PF_TOGGLE, "y_chk", "Y checkerboard", True) 64 | ], 65 | [], 66 | python_8bit_dither) 67 | 68 | main() 69 | -------------------------------------------------------------------------------- /hacks/dollhouse.lisp: -------------------------------------------------------------------------------- 1 | ;;;; This is a graphics demo. It horizontally scrolls a portion of 2 | ;;;; some artwork by Mark Ryden, in various colors, with some sinebobs 3 | ;;;; (?) and a wavy raster effect on top. The art is converted from a 4 | ;;;; GIF file to an 8 KB character ROM during assembly. The image is 5 | ;;;; large enough that we need some timed code to switch pattern table 6 | ;;;; banks mid-frame. It also incorporates a simple music player, 7 | ;;;; with the music described in a simple embedded DSL that compiles 8 | ;;;; down to a sequence of register writes to drive the 2A03 sound 9 | ;;;; hardware. 10 | 11 | ;;;; It targets a basic NROM board (32KB program, 8KB character, 12 | ;;;; vertical mirroring). I've tested it on an EPROM cart made from a 13 | ;;;; Gyromite board. 14 | 15 | ;;;; I'm neither a demo coder nor particularly experienced at 6502 16 | ;;;; assembly language, so expect nothing clever here. 17 | 18 | ;;;; (Somewhat embarrassingly, this demo reveals a bug in my own NES 19 | ;;;; emulator which I've yet to fix, where the frame timing is 20 | ;;;; apparently off by one scanline. Oops.) 21 | 22 | (defpackage :dollhouse-demo 23 | (:use :common-lisp :6502 :6502-modes :asm6502 :asm6502-utility :asm6502-nes :nesmus)) 24 | 25 | (in-package :dollhouse-demo) 26 | 27 | (defvar *path* #.*compile-file-pathname*) 28 | 29 | ;;;; ********************************************************************* 30 | ;;;; ( You are now about to witness the strength of street knowledge. ;) 31 | 32 | (let* ((global (make-instance 'basic-context :address #x8000)) 33 | (*context* global) 34 | (num-wavy-lines (* 3 26)) ; Must be multiple of 3 ! 35 | (log2-wavy-period 5) 36 | 37 | ;; Music player: 38 | (mfr-addr #x40) 39 | (mfr-get (indi mfr-addr)) 40 | (mptr #x42) 41 | (mptr-msb (zp (1+ mptr))) 42 | (mptr-lsb (zp mptr)) 43 | (log2-song-length 4) ; Base 2 log of song length. 44 | (write-patterns (make-hash-table :test 'equal)) 45 | (music-sequence '()) 46 | 47 | ;; Variables (graphics): 48 | (sprite-table #x0300) 49 | (table-x #x0200) 50 | (table-y #x0240) 51 | (countdown (zp #x58)) 52 | (wave (zp #x59)) 53 | (wt-lsb (zp #x60)) 54 | (wt-msb (zp #x61)) 55 | (wt-get (indi #x60)) 56 | (fill-count (zp #x91)) 57 | (scroll-x (zp #x92)) 58 | (phase (zp #x93)) 59 | (ntaddr (zp #x95)) 60 | (top-ntaddr (zp #x97)) 61 | (vblank-flag (zp #x96))) ; Set by NMI handler. 62 | 63 | ;; Step music playback. Advances MPTR. 64 | (procedure player-step 65 | 66 | ;; Transfer *MPTR to MFR and play this frame. 67 | (ldy (imm 0)) ; LSB of new music frame pointer 68 | (lda (indi mptr)) 69 | (sta (zp mfr-addr)) 70 | (iny) ; MSB of new music frame pointer 71 | (lda (indi mptr)) 72 | (sta (zp (1+ mfr-addr))) 73 | (jsr 'player-write) ; Play frame from MFR. 74 | 75 | ;; Advance music pointer 76 | (lda mptr-lsb) ; 16-bit addition: MPTR = (MPTR+2) mod song_len 77 | (clc) 78 | (adc (imm 2)) 79 | (sta mptr-lsb) 80 | (lda mptr-msb) 81 | (adc (imm 82 | (delay nil ((offset (msb (label 'music-start)))) 83 | (- 256 offset)))) 84 | (anda (imm (1- (expt 2 log2-song-length)))) 85 | (clc) 86 | (adc (imm (delay nil ((offset (msb (label 'music-start)))) 87 | offset))) 88 | (sta mptr-msb) 89 | 90 | (rts)) 91 | 92 | ;; Reset sound hardware and initialize music player. 93 | (procedure player-init 94 | (poke 0 #x4015) ; Silence all channels. 95 | (poke #x40 #x4017) ; IRQ off, 4-step. 96 | (ldx (imm #xF)) ; Zero the registers 97 | (lda (imm 0)) 98 | (as/until :negative 99 | (sta (abx #x4000)) 100 | (dex)) 101 | (poke 0 #x4011) ; Hit the DMC DAC, for good measure. 102 | (poke #x0F #x4015) ; Enable square, triangle, noise. 103 | 104 | (pokeword (label 'music-start) mptr) ; Set initial playback pointer. 105 | (rts)) 106 | 107 | (procedure reset ; ------------------------------------ 108 | (sei) 109 | (cld) 110 | (poke #b00010000 +ppu-cr1+) ; NMI off during init. 111 | (poke #b00000000 +ppu-cr2+) ; Do turn the screen off too.. 112 | (ldx (imm #xFF)) ; Set stack pointer 113 | (txs) 114 | 115 | ;; Init sound hardware 116 | (poke 0 #x4015) ; Silence all channels 117 | (poke #x40 #x4017) ; Disable IRQ !! 118 | 119 | (as/until :negative (bita (mem +ppu-status+))) ; PPU warmup interval 120 | (as/until :negative (bita (mem +ppu-status+))) ; (two frames) 121 | 122 | ;; Paranoid initialization. Had some intermittent quicks on real 123 | ;; hardware, as though the nametables weren't fully initialized, 124 | ;; so I've inserted a bunch of paranoid vblank syncs, and call the 125 | ;; init routine multiple times just to be sure. 126 | (lda (imm 3)) 127 | (sta countdown) 128 | (as/until :zero 129 | (jsr 'init-nametable) 130 | (jsr 'init-attr) 131 | (jsr 'init-palette) 132 | (dec countdown)) 133 | 134 | (jsr 'player-init) ; Initialize music player 135 | 136 | (lda (imm 64)) ; Initialize scroll variables 137 | (sta scroll-x) 138 | (lda (imm 0)) 139 | (sta ntaddr) 140 | (sta wave) 141 | (lda (imm 159)) 142 | (sta phase) 143 | 144 | (jsr 'initialize-sprites) 145 | 146 | (jsr 'update-sprites) 147 | 148 | (lda (imm 0)) ; Don't forget to reset this. 149 | (sta vblank-flag) 150 | 151 | (align 256 #xEA) ; Pad with NOPs to next page 152 | (poke #b10001000 +ppu-cr1+) ; Enable NMI 153 | 154 | (with-label mainloop 155 | (macrolet ((repeat (times &body body) 156 | `(progn 157 | (lda countdown) 158 | (pha) 159 | (lda (imm ,(if (eql times 256) 160 | 0 161 | times))) 162 | (sta countdown) 163 | (as/until :zero 164 | ,@(if (and (= 1 (length body)) 165 | (symbolp (first body))) 166 | `((jsr ',(first body))) 167 | body) 168 | (dec countdown)) 169 | (pla) 170 | (sta countdown))) 171 | (scroll-panels () 172 | `(poke 0 phase)) 173 | (stop-panels () 174 | `(poke 159 phase))) 175 | 176 | ;; Show them the circle. 177 | (repeat 192 linearly) 178 | ;; Introduce the split, gently. 179 | (repeat 3 180 | (scroll-panels) 181 | (repeat 128 split-by-4) 182 | (repeat 128 linearly)) 183 | ;; Compare/contrast: 184 | (repeat 2 185 | (scroll-panels) 186 | (repeat 128 187 | (jsr 'spin-apart) 188 | (jsr 'linearly)) 189 | (repeat 128 linearly) 190 | (scroll-panels) 191 | (repeat 128 split-by-4) 192 | (repeat 128 linearly)) 193 | (repeat 64 split-by-4) 194 | (repeat 96 linearly) 195 | ;; Change it up. 196 | (repeat 256 spin-apart) 197 | (repeat 96 linearly) 198 | ;; A little more intense.. 199 | (repeat 5 200 | (repeat 24 split-by-4) 201 | (repeat 96 linearly)) 202 | (repeat 88 split-by-4) 203 | ;; Slow down.. 204 | (repeat 256 205 | (scroll-panels) 206 | (jsr 'split-by-4) 207 | (jsr 'spin-apart)) 208 | (stop-panels) 209 | ;; Rest and repeat. Come a little unglued. 210 | (repeat 256 spin-apart) 211 | (repeat 253 spin-apart) 212 | 213 | (jmp (mem 'mainloop))))) 214 | 215 | ;;; Do register writes for this frame of music. Set MFR to the 216 | ;;; set of writes for this frame (16*2 bytes). 217 | (procedure player-write 218 | (ldy (imm #x1F)) 219 | (as/until :negative 220 | (lda mfr-get) 221 | (tax) 222 | (dey) 223 | (lda mfr-get) 224 | (sta (abx #x4000)) 225 | (dey)) 226 | (rts)) 227 | 228 | (procedure init-nametable 229 | ;; Fill nametable. 230 | (as/until :negative (bita (mem +ppu-status+))) 231 | (ppuaddr #x2000) 232 | (jsr 'fill-nametable) 233 | (as/until :negative (bita (mem +ppu-status+))) 234 | (ppuaddr #x2400) 235 | (jsr 'fill-nametable) 236 | (rts)) 237 | 238 | (procedure init-attr 239 | ;; Fill attribute table. 240 | (as/until :negative (bita (mem +ppu-status+))) 241 | (ppuaddr #x23C0) 242 | (ldy (imm 0)) 243 | (lda (imm #b01010101)) 244 | (jsr 'fill-attributes) 245 | (as/until :negative (bita (mem +ppu-status+))) 246 | (ppuaddr #x27C0) 247 | (ldy (imm #b10101010)) 248 | (lda (imm #b11111111)) 249 | (jsr 'fill-attributes) 250 | (rts)) 251 | 252 | (procedure init-palette 253 | ;; Program palette. 254 | (ppuaddr #x3F00) 255 | (dolist (color '(#x3F #x2D #x3D #x30 #x3F #x03 #x13 #x23 256 | #x3F #x2D #x3D #x30 #x3F #x05 #x15 #x25 257 | #x3F #x3F #x27 #x37)) 258 | (poke color +vram-io+)) 259 | (rts)) 260 | 261 | (align 256) 262 | (procedure framestep 263 | (jsr 'wait-for-vblank) 264 | (lda (mem +ppu-status+)) ; Reset PPU address latch. 265 | (poke 0 +spr-addr+) ; Reset sprite address! 266 | (lda (imm (msb sprite-table))) ; Sprite DMA transfer. 267 | (sta (mem +sprite-dma+)) 268 | 269 | (lda (mem +ppu-status+)) ; Reset address latch, to be safe. 270 | (ldx phase) ; 'phase' steps through rate-pattern 271 | (lda scroll-x) ; Scroll horizontally.. 272 | (clc) ; Update scroll-x by rate-pattern 273 | (adc (abx 'rate-pattern)) ; Add. Use the carry-out below! 274 | (sta scroll-x) 275 | (lda (abx 'rate-transition)) ; Update phase via transition function. 276 | (sta phase) 277 | (lda ntaddr) ; Carry into ntaddr 278 | (adc (imm 0)) ; ** Carry in from ADC above. ** 279 | (anda (imm #b00000001)) ; Carry toggles $2000/$2400 280 | ;; (*) Subtle: I had to bum an instruction out of the scanline kernel, so 281 | ;; I store this with bit 4 inverted, as the bottom half of the screen 282 | ;; requires. 283 | (eor (imm #b10011000)) ; NMI on, invert BG Pattern address! (*) 284 | (sta ntaddr) 285 | 286 | ;; This got a little messy. Arithmetic for the bottom half of the screen 287 | ;; is biased by 128, because it's easier than screwing with the overflow 288 | ;; flag (the wave offsets are signed). Must adjust the top half to match. 289 | ;; There's also the issue of the gap between the screen split and the wave 290 | ;; effect, which also needs the correct value from here ("top-ntaddr"). 291 | (lda scroll-x) 292 | (clc) 293 | (adc (imm 128)) 294 | (sta (mem +vram-scroll+)) 295 | (lda ntaddr) ; Carry into NT address. 296 | (adc (imm 0)) ; (okay if it carries again) 297 | (eor (imm #b00010000)) ; Flip pattern table address. 298 | (sta top-ntaddr) ; Reuse this after the split. 299 | (sta (mem +ppu-cr1+)) 300 | 301 | (poke #b00011110 +ppu-cr2+) ; BG and sprites on. 302 | (lda (imm 0)) 303 | (sta (mem +vram-scroll+)) 304 | 305 | (jsr 'update-sprites) 306 | 307 | ;; Switch pattern tables mid-frame: 308 | (emit-delay (+ (* 114 107) 22)) 309 | (lda top-ntaddr) 310 | (eor (imm #b10010000)) ; Invert pattern bank. 311 | (sta (mem +ppu-cr1+)) 312 | 313 | ;; Run the music 314 | (jsr 'player-step) 315 | 316 | ;; Leftover scanlines before wave effect starts 317 | (emit-delay (round (+ (* 113.66 9) 110))) 318 | 319 | ;; Wavy effect 320 | (flet ((kernel () 321 | ;; Assumes Y counts down each line.. 322 | (poke #b00011110 +ppu-cr2+) ; To visually calibrate timing. 323 | (clc) 324 | (lda wt-get) ; Get wave offset 325 | (adc scroll-x) ; Add to BG scroll position 326 | (ldx (imm 0)) 327 | (sta (mem +vram-scroll+)) 328 | (stx (mem +vram-scroll+)) 329 | (lda ntaddr) ; Carry in. Effectively, scroll-x and 330 | (adc (imm 0)) ; ntaddr.0 form a 9-bit field. 331 | (sta (mem +ppu-cr1+)) 332 | (poke #b00011110 +ppu-cr2+))) 333 | 334 | ;; Setup for wave effect.. load table pointer into zero page. 335 | (inc wave) ; Increment wave phase 336 | (lda wave) 337 | (anda (imm (1- (expt 2 log2-wavy-period)))) ; Modulo cycle length.. 338 | (lsr) 339 | (clc) 340 | (adc (imm (msb (label 'wave-offsets)))) ; Calculate table MSB 341 | (sta wt-msb) 342 | (lda wave) 343 | (lsr) 344 | (lda (imm 0)) ; Rotate into MSB of LSB (...) 345 | (ror) ; (each table is 128 bytes) 346 | (adc (imm (lsb (label 'wave-offsets)))) 347 | (sta wt-lsb) 348 | 349 | (emit-delay 47) ; Realign with hblank 350 | (bita (zp 0)) 351 | (nop) 352 | 353 | (macrolet ((reporting-timing (&body body) 354 | `(print (list :kernel-cycles 355 | (counting-cycles ,@body))))) 356 | 357 | (ldy (imm num-wavy-lines)) ; Decremented within scanline kernel. 358 | 359 | (loop repeat (/ num-wavy-lines 3) do 360 | (reporting-timing (kernel) (dey)) 361 | (loop repeat 14 do (inc (zp 0))) 362 | (reporting-timing (kernel) (dey)) 363 | (nop) 364 | (loop repeat 14 do (inc (zp 0))) 365 | (reporting-timing (kernel) (dey)) 366 | (loop repeat 14 do (inc (zp 0)))))) 367 | 368 | ;; Shut the screen off. Need a few extra scanlines here to update 369 | ;; the sprite tables, and if I didn't shut it off, you'd notice 370 | ;; the background stopped waving. 371 | (loop repeat 10 do (nop)) ; Realign with hblank.. again. 372 | ;; Actually, leave the sprites on, otherwise they'll be disabled 373 | ;; during the DMA transfer, which is unwise. 374 | (poke #x10 +ppu-cr2+) 375 | 376 | (rts)) 377 | 378 | ;; This table controls the scrolling. 379 | (align 256) 380 | (with-label rate-pattern 381 | (let* ((tr '(1 0 1 0 1 0 1 0 0 1 0 0 1 0 0 0 1)) 382 | (pattern (subseq 383 | (append (loop repeat (- 128 (reduce '+ tr)) 384 | collect 1) 385 | tr 386 | (loop repeat 256 collect 0)) 387 | 0 256))) 388 | (assert (= 256 (length pattern))) 389 | (assert (= 128 (reduce #'+ pattern))) 390 | (map nil 'db pattern))) 391 | (with-label rate-transition 392 | (loop for i from 0 below 160 do (db (1+ i))) 393 | (db 160)) 394 | 395 | (procedure fill-nametable 396 | (lda (imm 30)) 397 | (sta fill-count) 398 | (ldx (imm 0)) 399 | (as/until :zero 400 | (txa) 401 | (ldy (imm 16)) 402 | (as/until :zero 403 | (stx (mem +vram-io+)) 404 | (inx) 405 | (dey)) 406 | (tax) ; ..and once more. 407 | (ldy (imm 16)) 408 | (as/until :zero 409 | (stx (mem +vram-io+)) 410 | (inx) 411 | (dey)) 412 | (dec fill-count))) 413 | 414 | (procedure fill-attributes 415 | (ldx (imm 8)) 416 | (as/until :zero 417 | (dotimes (x 4) (sty (mem +vram-io+))) 418 | (dotimes (x 4) (sta (mem +vram-io+))) 419 | (dex)) 420 | (rts)) 421 | 422 | (procedure initialize-sprites 423 | ;; Initialize OAM mirror. 424 | (ldx (imm 0)) 425 | (as/until :zero 426 | (poke 96 (abx sprite-table)) ; Y coordinate 427 | (inx) 428 | (txa) ; Alternate character #s 429 | (lsr) 430 | (lsr) ; 431 | (ora (imm #xFE)) 432 | (sta (abx sprite-table)) ; Sprite index 433 | (inx) 434 | (poke 0 (abx sprite-table)) ; Attirubtes 435 | (inx) 436 | (poke 64 (abx sprite-table)) ; X coordinate 437 | (inx)) 438 | ;; Initialize X/Y phase variables 439 | (ldx (imm 63)) 440 | (lda (imm 0)) 441 | (as/until :negative 442 | (sta (abx table-x)) 443 | (sta (abx table-y)) 444 | (clc) 445 | (adc (imm 4)) 446 | (dex)) 447 | (rts)) 448 | 449 | (procedure linearly 450 | (jsr 'framestep) 451 | (ldx (imm 63)) 452 | (as/until :negative 453 | (print 454 | (counting-cycles 455 | (inc (abx table-x)) 456 | (inc (abx table-y)) 457 | (dotimes (i 7) (nop)) 458 | (dex)))) 459 | (rts)) 460 | 461 | (procedure spin-apart 462 | (jsr 'framestep) 463 | (ldx (imm 63)) 464 | (as/until :negative 465 | (print 466 | (counting-cycles 467 | (inc (abx table-x)) 468 | (txa) 469 | (anda (imm 1)) 470 | (clc) 471 | (adc (abx table-x)) 472 | (sta (abx table-x)) 473 | (dotimes (i 3) (nop)) 474 | (dex)))) 475 | (rts)) 476 | 477 | (procedure split-by-4 478 | (jsr 'framestep) 479 | (ldx (imm 63)) 480 | (as/until :negative 481 | (print 482 | (counting-cycles 483 | (inc (abx table-y)) 484 | (txa) 485 | (anda (imm 16)) 486 | (lsr) 487 | (lsr) 488 | (lsr) 489 | (clc) 490 | (adc (abx table-x)) 491 | (sta (abx table-x)) 492 | (dex)))) 493 | (rts)) 494 | 495 | (procedure wait-for-vblank 496 | (lda (imm 0)) 497 | (sta vblank-flag) 498 | (as/until :not-zero (lda vblank-flag)) 499 | (lda (imm 0)) 500 | (sta vblank-flag) 501 | (rts)) 502 | 503 | (procedure brk-handler (rti)) 504 | 505 | (procedure vblank-handler 506 | (inc vblank-flag) 507 | (rti)) 508 | 509 | (align 256) 510 | (procedure update-sprites 511 | (ldx (imm 63)) 512 | (as/until :negative 513 | (ldy (abx table-x)) ; Push sin[table_x[X]] 514 | (lda (aby 'sine-table)) 515 | (pha) 516 | 517 | (lda (abx table-y)) ; Push sin[table_x[X]+64] 518 | (clc) 519 | (adc (imm 64)) 520 | (tay) 521 | (lda (aby 'sine-table)) 522 | (pha) 523 | 524 | (txa) ; A = X * 4 525 | (asl) 526 | (asl) 527 | (tay) ; Y = X * 4 528 | (pla) ; Pop cosine 529 | (clc) 530 | (adc (imm -14)) ; Offset Y coordinate 531 | (sta (aby sprite-table)) ; Store in sprite Y coordinate 532 | (pla) ; Pop sine 533 | (sta (aby (+ 3 sprite-table))) ; Store in sprite X coordinate 534 | (dex)) ; Decrement sprite index 535 | (rts)) 536 | 537 | (align 256) 538 | (with-label sine-table 539 | (loop for i from 0 below 256 540 | do (db (round (+ 124 (* 99 (sin (* 2 pi i 1/256)))))))) 541 | 542 | (align 256) 543 | (with-label wave-offsets 544 | (loop with nframes = (expt 2 log2-wavy-period) 545 | for frame from (1- nframes) downto 0 do 546 | (align 128) 547 | (emit 548 | ;; The wave loop counts from num-wavy-lines to 1. So, one extra here. 549 | (loop for line from num-wavy-lines downto 0 550 | with amp = 2 551 | collect (mod (round ( + 128 ; bias to fix carry 552 | (* amp (/ (expt line 1.1) 80) 553 | (sin (* 2 pi (/ (+ (* 0.07 (expt line 1.75)) frame) 554 | nframes)))))) 555 | 256))))) 556 | 557 | (format t "~&Code ends at at ~X~%" *origin*) 558 | 559 | ;; ************************************************************ 560 | ;; MUSIC 561 | 562 | (labels 563 | ((emit-frame (frame) 564 | (unless (<= (length frame) 16) 565 | (error "Too many writes! ~X" (mapcar 'second frame))) 566 | (setf frame (pad-frame frame)) 567 | (unless (gethash frame write-patterns) 568 | (setf (gethash frame write-patterns) *origin*) 569 | ;; Reverse order, because player scans backward! 570 | (dolist (pair (reverse frame)) (apply 'db pair))) 571 | (push (gethash frame write-patterns) music-sequence)) 572 | 573 | (song (frames) 574 | (map nil (lambda (frame) (emit-frame (resolve-tree frame))) frames)) 575 | 576 | ;; Song elements: 577 | 578 | (phrase-aaab (a b) (seq a a a b)) 579 | 580 | (four-on-the-floor () (repeat 4 (thump 32 (et -24)))) 581 | 582 | (rhythm (fn notes &optional (transpose 0)) 583 | (seq 584 | (funcall fn 32 (et transpose (nth 0 notes))) 585 | (funcall fn 24 (et transpose (nth 1 notes))) 586 | (funcall fn 16 (et transpose (nth 2 notes))) 587 | (funcall fn 24 (et transpose (nth 3 notes))) 588 | (funcall fn 32 (et transpose (nth 4 notes))))) 589 | 590 | (swagger () 591 | (seq 592 | (kick 16) 593 | (hat 8) 594 | (hat 8) 595 | (snare 16) 596 | (hat 8) 597 | (hat 8 4))) 598 | 599 | (stagger () 600 | (seq 601 | (hat 8) 602 | (kick 8) 603 | (hat 8) 604 | (hat 8) 605 | (snare 16) 606 | (rst 16))) 607 | 608 | (jagger () 609 | (seq 610 | (shaker 8 15) 611 | (shaker 8 4) 612 | (shaker 8 8) 613 | (shaker 8 12) 614 | (shaker 8 15) 615 | (shaker 8 5) 616 | (shaker 8 11) 617 | (shaker 8 14))) 618 | 619 | (intro-beat () 620 | (measure 621 | (four-on-the-floor) 622 | (seq 623 | (swagger) 624 | (swagger)))) 625 | 626 | (intro-fill-1 () 627 | (measure 628 | (four-on-the-floor) 629 | (seq (swagger) 630 | (stagger)))) 631 | 632 | (intro-fill-2 () 633 | (measure 634 | (four-on-the-floor) 635 | (seq (jagger) 636 | (jagger))))) 637 | 638 | (align 32) 639 | 640 | (song 641 | (seq 642 | ;; Smooth section 643 | (seq 644 | (para 645 | (phrase-aaab 646 | (intro-beat) 647 | (intro-fill-1)) 648 | (seq 649 | (measure (fat-arp 128 '(0.00 0 3 7 11) :rate 4 :volume (volramp 8 -1/22))) 650 | (measure (fat-arp 128 '(0.00 0 2 5 8 ) :rate 4 :volume (volramp 8 -1/22))) 651 | (measure (fat-arp 128 '(0.00 -2 7 8 12 ) :rate 4 :volume (volramp 9 -1/20))) 652 | (measure (fat-arp 128 '(0.00 -1 2 3 7 ) :rate 4 :volume (volramp 10 -1/18))))) 653 | 654 | (para 655 | (phrase-aaab 656 | (intro-beat) 657 | (intro-fill-2)) 658 | (seq 659 | (measure (arpeggio 0 128 (chord -0.02 0 3 7 11) :rate 4 :volume (volramp 11 -1/16)) 660 | (arpeggio 1 128 (chord 0.02 12 0 3 14 7 11) :rate 3 :volume (volramp 11 -1/13))) 661 | (measure (arpeggio 0 128 (chord -0.02 0 2 5 8) :rate 4 :volume (volramp 12 -1/14)) 662 | (arpeggio 1 128 (chord 0.02 2 5 8 12 15) :rate 3 :volume (volramp 12 -1/14))) 663 | (measure (arpeggio 0 128 (chord -0.02 -2 7 8 12) :rate 4 :volume (volramp 13 -1/12)) 664 | (arpeggio 1 128 (chord 0.02 5 15 8 12 15 17) :rate 3 :volume (volramp 13 -1/12))) 665 | (measure (arpeggio 0 128 (chord -0.02 -1 2 3 7) :rate 4 :volume (volramp 15 -1/10) :mute t) 666 | (arpeggio 1 128 (chord 0.02 3 7 14 11 19 14) :rate 4 :volume (volramp 15 -1/10) :mute t))))) 667 | 668 | ;; Funky section 669 | (seq 670 | (para 671 | (phrase-aaab 672 | (measure 673 | (rhythm #'thump '(0 0 0 0 7) -12) 674 | (seq (swagger) (stagger))) 675 | (measure 676 | (seq (stagger) (stagger)) 677 | (four-on-the-floor))) 678 | (seq 679 | (measure 680 | (funky-arp 0 12 0 3 11 14 7 17 0 17 12 19 15 17 10 15)) 681 | (measure 682 | (para 683 | (note 0 32 (et 0.026) :cfg '(:duty 1 :env t :vol 2 :loop nil)) 684 | (note 1 32 (et -0.026) :cfg '(:duty 3 :env t :vol 2 :loop nil)))) 685 | (measure 686 | (funky-arp 5 0 5 7 8 11 12 0 12 17 15 17 15 14 12 8 7)) 687 | (measure 688 | (funky-arp 7 0 7 11 12 3 17 19 20 24 23 20 0 19 17 20)))) 689 | (para 690 | (phrase-aaab 691 | (measure 692 | (seq (swagger) (stagger)) 693 | (rhythm #'thump '(0 3 3 -2 0) -12)) 694 | (measure 695 | (seq (stagger) (jagger)))) 696 | (seq 697 | (measure 698 | (fat-arp 128 '(0.0 0 12 0 3 11 14 7 17 0 17 12 19 15 17 20 19) 699 | :d 6 :rate 8 :env t :loop nil :volume (constantly 3) :mute nil)) 700 | (measure 701 | (seq 702 | (para 703 | (note 0 32 (et 0.026 24) :cfg '(:duty 1 :env t :vol 2 :loop nil)) 704 | (note 1 32 (et -0.026 24) :cfg '(:duty 3 :env t :vol 0 :loop nil))) 705 | (para 706 | (note 0 32 (et 0.026 24) :cfg '(:duty 1 :env t :vol 2 :loop nil)) 707 | (note 1 32 (et -0.026 12) :cfg '(:duty 3 :env t :vol 2 :loop nil))))) 708 | (measure 709 | (fat-arp 128 '(5.0 0 3 7 0 3 7 0 3 8 0 3 7 0 3 8) :rate 4 :d 3 :volume (volramp 10 -1/18))) 710 | (measure 711 | (fat-arp 128 '(0.0 2 5 8 11 2 5 8 14) :rate 4 :d 3 :volume (volramp 9 -1/18)))))))) 712 | 713 | (align 256) 714 | (with-label music-start 715 | (unless (= (length music-sequence) (* 128 (expt 2 log2-song-length))) 716 | (error "Song length is ~:D, should be ~:D" 717 | (length music-sequence) 718 | (* 128 (expt 2 log2-song-length)))) 719 | (print (list :num-unique (length (remove-duplicates music-sequence)))) 720 | ;; Write the pointer table: 721 | (mapcar #'dw (reverse music-sequence)))) 722 | 723 | ;; ************************************************************ 724 | 725 | (format t "~&Empty space begins at ~X~%" *origin*) 726 | 727 | ;; Interrupt vectors: 728 | (advance-to +nmi-vector+) 729 | (dw (label 'vblank-handler)) 730 | (dw (label 'reset)) 731 | (dw (label 'brk-handler)) 732 | 733 | ;; Create output file: 734 | (write-ines "/tmp/dollhouse.nes" 735 | (link global) 736 | :mirror-mode :vertical 737 | :chr (ichr:encode-chr 738 | (ichr:read-gif 739 | (merge-pathnames "ryden.gif" *path*))))) 740 | -------------------------------------------------------------------------------- /hacks/fingers_30299.pcm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ahefner/asm6502/802daae092f8ab2c50eb469497ee03b30474f2a7/hacks/fingers_30299.pcm -------------------------------------------------------------------------------- /hacks/music-demo.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Music demo: Looping audio through the 7-bit DAC. 2 | 3 | ;;;; This program will treat the listener to a seamlessly looping 4 | ;;;; excerpt from one of western music's great achievements, 5 | ;;;; "Can You Feel It" by Mr. Fingers. 6 | 7 | ;;;; It plays an 8 second (240KB) musical loop at 30.3 KHz. This rate 8 | ;;;; was selected to fit the music loop into exactly the space 9 | ;;;; available. The sound quality is surprisingly good (though less so 10 | ;;;; on emulators other than my own, because of different DAC curves). 11 | 12 | (defpackage :music-demo 13 | (:use :common-lisp :6502 :6502-modes :asm6502 :asm6502-utility :asm6502-nes)) 14 | 15 | (in-package :music-demo) 16 | 17 | (defvar *path* #.*compile-file-truename*) 18 | 19 | ;; Load the raw 8-bit PCM data. 20 | 21 | ;; PROCESS-DAC-WAVEFORM corrects for my claimed DAC non-linearity, 22 | ;; and add some bogus dithering. (I can't hear a real difference no 23 | ;; matter how I tweak the dither settings). 24 | 25 | (defun load-audio () 26 | (process-dac-waveform 27 | (binary-file (merge-pathnames "fingers_30299.pcm" *path*)) 28 | :prescale 0.5 29 | :error-feedback 1.0)) 30 | 31 | (macrolet 32 | ((program ((filename &rest rom-args) &body body) 33 | `(let ((program 34 | (concatenate 35 | 'vector 36 | ;; Audio banks: 37 | (load-audio) 38 | ;; Program bank: 39 | (let ((*context* (make-instance 40 | 'basic-context 41 | :address #xC000))) 42 | ,@body 43 | (link *context*))))) 44 | (setf (binary-file "/tmp/prg.bin") program) 45 | (write-ines ,filename program ,@rom-args)))) 46 | (program ("/tmp/music-demo.nes" :mapper 4) 47 | (advance-to #xE000) ; Put everything in the last bank. 48 | (with-label nmi (rti)) 49 | (with-label irq (rti)) 50 | (with-label reset 51 | ;; Initialize 52 | (sei) 53 | (cld) 54 | (ldx (imm #xFF)) 55 | (txs) 56 | (poke 0 +ppu-cr1+) ; Disable NMI 57 | (poke 0 +ppu-cr2+) ; Disable display 58 | (poke 0 +papu-control+) ; Silence audio 59 | (ppuaddr #x3F00) 60 | (poke #x17 +vram-io+) 61 | (ppuaddr #x3F00) 62 | 63 | (poke 6 #x8000) ; Select first bank 64 | (poke 0 #x8001) 65 | 66 | (ldy (imm 0)) 67 | (poke 0 (zp 3)) ; LSB of playback page (always zero) 68 | (poke #x80 (zp 4)) ; MSB of playback pointer 69 | (poke 0 (zp 5)) ; Current bank 70 | 71 | (align 256 #xEA) 72 | 73 | (with-label :loop 74 | (let* ((inner-cycles 75 | (counting-cycles 76 | (lda (indi 3)) ; Load audio byte 77 | (sta (mem +dmc-dac+)) ; Write to DAC register 78 | (tya) ; Increment audio pointer... 79 | (clc) 80 | (adc (imm 1)) 81 | (tay) 82 | (lda (zp 4)) ; Carry into high address byte 83 | (adc (imm 0)) 84 | (tax) 85 | (lda (abx (label :msbtable :offset (- #x80)))) 86 | (lsr) ; Low bit is carry into bank number 87 | (ora (imm #x80)) 88 | (sta (zp 4)) 89 | 90 | ;; I think I can get away without resetting #x8000 91 | ;; inside the loop, and I need the cycles. 92 | ;; This should be tested on real hardware. 93 | ;; Works on PowerPak... 94 | ;;(lda (imm 6)) ; Select low bank 95 | ;;(sta (mem #x8000)) 96 | 97 | (lda (zp 5)) ; Carry into bank number 98 | (adc (imm 0)) 99 | (tax) 100 | (lda (abx :banktable)) 101 | (sta (mem #x8001)) ; Select bank and write back 102 | (sta (zp 5)) 103 | 104 | ;; Add 3 extra cycles for the jump at the bottom of the loop: 105 | (context-note-cycles *context* 3))) 106 | (clock 1789772.5) 107 | (freq 30299) 108 | (loop-cycles (round clock freq)) 109 | (delay-cycles (- loop-cycles inner-cycles))) 110 | 111 | (unless (<= inner-cycles loop-cycles) 112 | (cerror "Screw it." 113 | "Loop is too slow! ~A cycles, need ~A" 114 | inner-cycles loop-cycles)) 115 | (format t "~&Inner cycles: ~D 116 | Target frequency: ~D 117 | Target cycles: ~D 118 | Need to delay for ~D cycles 119 | Actual frequency: ~D" 120 | inner-cycles freq loop-cycles delay-cycles 121 | (/ clock loop-cycles)) 122 | 123 | (emit-delay (max 0 delay-cycles)) 124 | (jmp (mem :loop))))) 125 | 126 | ;; This table controls the wrapping from #x9F00 to #x8000 page, and increment of the bank number 127 | (with-label :msbtable 128 | (loop for i from 0 upto 32 129 | do (db (logior (ash (mod i 32) 1) (if (= i 32) 1 0))))) 130 | 131 | ;; This table controls wrapping from bank 14 to bank 0 132 | (with-label :banktable 133 | (loop for bank from 0 upto 30 do (db (mod bank 30)))) 134 | 135 | (advance-to +nmi-vector+) 136 | (dw (label 'nmi)) 137 | (dw (label 'reset)) 138 | (dw (label 'irq)))) 139 | 140 | -------------------------------------------------------------------------------- /hacks/music-test.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Compiling this file will result in an output file /tmp/dollhouse.nsf 2 | 3 | (defpackage :music-test 4 | (:use :common-lisp :6502 :6502-modes :asm6502 :asm6502-utility :asm6502-nes :nesmus)) 5 | 6 | (in-package :music-test) 7 | 8 | #+KILLME 9 | (defun wait (&optional (frames 20)) 10 | (ldx (imm frames)) 11 | (as/until :zero (jsr 'wait) (dex))) 12 | 13 | ;;;; ********************************************************************** 14 | 15 | (let* ((*context* (make-instance 'basic-context :address 0)) 16 | 17 | ;; Music player 18 | (mfr-addr #x40) 19 | (mfr-get (indi mfr-addr)) 20 | (mptr #x42) 21 | (mptr-msb (zp (1+ mptr))) 22 | (mptr-lsb (zp mptr)) 23 | (log2-song-length 4) ; Base 2 log of song length. 24 | 25 | ;; Reduce space by reusing patterns of registers. 26 | (regs-table (make-hash-table :test 'equal)) 27 | (histogram (make-array 16)) 28 | (music-sequence '()) 29 | 30 | #+NIL (vblank-flag (zp #x96))) 31 | 32 | ;;; Build file header 33 | (emit-nsf-header 1 :load 'reset 'player-step 34 | :song-name "Dollhouse" 35 | :artist "Andy Hefner ") 36 | (setf *origin* #x8000) 37 | (set-label :load) 38 | 39 | ;;; Do register writes for this frame of music. Set MFR to the 40 | ;;; set of writes for this frame (16*2 bytes). 41 | (procedure player-write 42 | (ldy (imm #x1F)) 43 | (as/until :negative 44 | (lda mfr-get) 45 | (tax) 46 | (dey) 47 | (lda mfr-get) 48 | (sta (abx #x4000)) 49 | (dey)) 50 | (rts)) 51 | 52 | ;; Step music playback. Advances MFR. 53 | (procedure player-step 54 | 55 | ;; Transfer *MPTR to MFR and play this frame. 56 | (ldy (imm 0)) ; LSB of new music frame pointer 57 | (lda (indi mptr)) 58 | (sta (zp mfr-addr)) 59 | (iny) ; MSB of new music frame pointer 60 | (lda (indi mptr)) 61 | (sta (zp (1+ mfr-addr))) 62 | (jsr 'player-write) ; Play frame from MFR. 63 | 64 | ;; Advance music pointer 65 | (lda mptr-lsb) ; 16-bit addition: MPTR = (MPTR+2) mod song_len 66 | (clc) 67 | (adc (imm 2)) 68 | (sta mptr-lsb) 69 | (lda mptr-msb) 70 | (adc (imm 71 | (delay nil ((offset (msb (label 'music-start)))) 72 | (- 256 offset)))) 73 | (anda (imm (1- (expt 2 log2-song-length)))) 74 | (clc) 75 | (adc (imm (delay nil ((offset (msb (label 'music-start)))) 76 | offset))) 77 | (sta mptr-msb) 78 | 79 | (rts)) 80 | 81 | 82 | (labels 83 | ((emit-frame (frame) 84 | (unless (<= (length frame) 16) 85 | (error "Too many writes! ~X" (mapcar 'second frame))) 86 | (incf (aref histogram (length frame))) 87 | (setf frame (pad-frame frame)) 88 | (unless (gethash frame regs-table) 89 | (setf (gethash frame regs-table) *origin*) 90 | ;; Reverse order, because player scans backward! 91 | (dolist (pair (reverse frame)) (apply 'db pair))) 92 | (push (gethash frame regs-table) music-sequence)) 93 | 94 | (song (frames) 95 | ;; So, I had this awesome idea of doing a sort of barber pole 96 | ;; "infinite modulation" by slowly sliding the tuning 97 | ;; downward through the course of the music loop via some 98 | ;; clever abuse of the delay/force mechanism.. but it turns 99 | ;; out there's not enough quite enough space in the ROM to do 100 | ;; it well without a more sophisticated player routine. Darn. 101 | (loop with initial-tuning = (* 261.0 (expt 2 1/12)) 102 | with final-tuning = (* initial-tuning #+NIL (expt 2 1/12)) 103 | with length = (length frames) 104 | with asm6502::*memoize-promises* = nil 105 | for frame in frames 106 | for position upfrom 0 107 | as frame-tuning = (+ initial-tuning (* (- final-tuning initial-tuning) 108 | (/ position length))) 109 | do (let ((*tuning-root* frame-tuning)) 110 | ;;(print (list :frame position :tuning frame-tuning :frame frame)) 111 | (emit-frame (resolve-tree frame))))) 112 | 113 | ;; Song elements: 114 | 115 | (phrase-aaab (a b) (seq a a a b)) 116 | 117 | (four-on-the-floor () (repeat 4 (thump 32 (et -24)))) 118 | 119 | (rhythm (fn notes &optional (transpose 0)) 120 | (seq 121 | (funcall fn 32 (et transpose (nth 0 notes))) 122 | (funcall fn 24 (et transpose (nth 1 notes))) 123 | (funcall fn 16 (et transpose (nth 2 notes))) 124 | (funcall fn 24 (et transpose (nth 3 notes))) 125 | (funcall fn 32 (et transpose (nth 4 notes))))) 126 | 127 | (swagger () 128 | (seq 129 | (kick 16) 130 | (hat 8) 131 | (hat 8) 132 | (snare 16) 133 | (hat 8) 134 | (hat 8 4))) 135 | 136 | (stagger () 137 | (seq 138 | (hat 8) 139 | (kick 8) 140 | (hat 8) 141 | (hat 8) 142 | (snare 16) 143 | (rst 16))) 144 | 145 | (jagger () 146 | (seq 147 | (shaker 8 15) 148 | (shaker 8 4) 149 | (shaker 8 8) 150 | (shaker 8 12) 151 | (shaker 8 15) 152 | (shaker 8 5) 153 | (shaker 8 11) 154 | (shaker 8 14))) 155 | 156 | (intro-beat () 157 | (measure 158 | (four-on-the-floor) 159 | (seq 160 | (swagger) 161 | (swagger)))) 162 | 163 | (intro-fill-1 () 164 | (measure 165 | (four-on-the-floor) 166 | (seq (swagger) 167 | (stagger)))) 168 | 169 | (intro-fill-2 () 170 | (measure 171 | (four-on-the-floor) 172 | (seq (jagger) 173 | (jagger))))) 174 | 175 | (align 16) 176 | 177 | (song 178 | (seq 179 | ;; Smooth section 180 | (seq 181 | (para 182 | (phrase-aaab 183 | (intro-beat) 184 | (intro-fill-1)) 185 | (seq 186 | (measure (fat-arp 128 '(0.00 0 3 7 11) :rate 4 :volume (volramp 8 -1/22))) 187 | (measure (fat-arp 128 '(0.00 0 2 5 8 ) :rate 4 :volume (volramp 8 -1/22))) 188 | (measure (fat-arp 128 '(0.00 -2 7 8 12 ) :rate 4 :volume (volramp 9 -1/20))) 189 | (measure (fat-arp 128 '(0.00 -1 2 3 7 ) :rate 4 :volume (volramp 10 -1/18))))) 190 | 191 | (para 192 | (phrase-aaab 193 | (intro-beat) 194 | (intro-fill-2)) 195 | (seq 196 | (measure (arpeggio 0 128 (chord -0.02 0 3 7 11) :rate 4 :volume (volramp 11 -1/16)) 197 | (arpeggio 1 128 (chord 0.02 12 0 3 14 7 11) :rate 3 :volume (volramp 11 -1/13))) 198 | (measure (arpeggio 0 128 (chord -0.02 0 2 5 8) :rate 4 :volume (volramp 12 -1/14)) 199 | (arpeggio 1 128 (chord 0.02 2 5 8 12 15) :rate 3 :volume (volramp 12 -1/14))) 200 | (measure (arpeggio 0 128 (chord -0.02 -2 7 8 12) :rate 4 :volume (volramp 13 -1/12)) 201 | (arpeggio 1 128 (chord 0.02 5 15 8 12 15 17) :rate 3 :volume (volramp 13 -1/12))) 202 | (measure (arpeggio 0 128 (chord -0.02 -1 2 3 7) :rate 4 :volume (volramp 15 -1/10) :mute t) 203 | (arpeggio 1 128 (chord 0.02 3 7 14 11 19 14) :rate 4 :volume (volramp 15 -1/10) :mute t))))) 204 | 205 | ;; Funky section 206 | (seq 207 | (para 208 | (phrase-aaab 209 | (measure 210 | (rhythm #'thump '(0 0 0 0 7) -12) 211 | (seq (swagger) (stagger))) 212 | (measure 213 | (seq (stagger) (stagger)) 214 | (four-on-the-floor))) 215 | (seq 216 | (measure 217 | (funky-arp 0 12 0 3 11 14 7 17 0 17 12 19 15 17 10 15)) 218 | (measure 219 | (repeat 2 220 | (para 221 | (note 0 32 (et 0.026) :cfg '(:duty 1 :env t :vol 2 :loop nil)) 222 | (note 1 32 (et -0.026) :cfg '(:duty 3 :env t :vol 2 :loop nil))))) 223 | (measure 224 | (funky-arp 5 0 5 7 8 11 12 0 12 17 15 17 15 14 12 8 7)) 225 | (measure 226 | (funky-arp 7 0 7 11 12 3 17 19 20 24 23 20 0 19 17 20)))) 227 | (para 228 | (phrase-aaab 229 | (measure 230 | (seq (swagger) (stagger)) 231 | (rhythm #'thump '(0 3 3 -2 0) -12)) 232 | (measure 233 | (seq (stagger) (jagger)))) 234 | (seq 235 | (measure 236 | (fat-arp 128 '(0.0 0 12 0 3 11 14 7 17 0 17 12 19 15 17 20 19) 237 | :d 6 :rate 8 :env t :loop nil :volume (constantly 3) :mute nil)) 238 | (measure 239 | (seq 240 | (para 241 | (note 0 32 (et 0.026 24) :cfg '(:duty 1 :env t :vol 2 :loop nil)) 242 | (note 1 32 (et -0.026 24) :cfg '(:duty 3 :env t :vol 0 :loop nil))) 243 | (para 244 | (note 0 32 (et 0.026 24) :cfg '(:duty 1 :env t :vol 2 :loop nil)) 245 | (note 1 32 (et -0.026 12) :cfg '(:duty 3 :env t :vol 2 :loop nil))))) 246 | (measure 247 | (fat-arp 128 '(5.0 0 3 7 0 3 7 0 3 8 0 3 7 0 3 8) :rate 4 :d 3 :volume (volramp 10 -1/18))) 248 | (measure 249 | (fat-arp 128 '(0.0 2 5 8 11 2 5 8 14) :rate 4 :d 3 :volume (volramp 9 -1/18)))))))) 250 | 251 | (print (list :histogram histogram)) 252 | 253 | (align 256) 254 | (with-label music-start 255 | (unless (= (length music-sequence) (* 128 (expt 2 log2-song-length))) 256 | (error "Song length is ~:D, should be ~:D" 257 | (length music-sequence) 258 | (* 128 (expt 2 log2-song-length)))) 259 | (print (list :num-unique (length (remove-duplicates music-sequence)))) 260 | (mapcar #'dw (reverse music-sequence)))) 261 | 262 | (print (list :music-size (- *origin* #x8000))) 263 | 264 | (procedure reset 265 | (cld) 266 | ;; Init sound hardware.. 267 | (poke 0 #x4015) ; Silence all channels. 268 | (ldx (imm #x11)) ; Zero the registers 269 | (lda (imm 0)) 270 | (as/until :negative 271 | (sta (abx #x4000)) 272 | (dex)) 273 | 274 | (poke #x0F #x4015) ; Enable square, triangle, noise. 275 | 276 | ;; Set initial song playback pointer: 277 | (pokeword (label 'music-start) mptr) 278 | (rts)) 279 | 280 | ;; Write .NSF file 281 | (setf (binary-file "/tmp/dollhouse.nsf") (link *context*))) 282 | -------------------------------------------------------------------------------- /hacks/nes-hacks.asd: -------------------------------------------------------------------------------- 1 | ;;;; This system is just here for testing changes the assembler. 2 | 3 | (asdf:defsystem :nes-hacks 4 | :name "NES Hacks" 5 | :description "Tests and hacks for the NES using asm6502." 6 | :author "Andy Hefner " 7 | :license "MIT-style licesnse" 8 | :serial t 9 | :depends-on (:asm6502 :ichr) 10 | :components ((:file "audio-test-1") 11 | (:file "music-demo") 12 | (:file "nes-hacklets") 13 | (:file "nes-test-1") 14 | (:file "nes-test-2") 15 | (:file "dollhouse"))) 16 | -------------------------------------------------------------------------------- /hacks/nes-test-1.lisp: -------------------------------------------------------------------------------- 1 | ;;;; This is a simple test of the assembler, targetting the NES, which 2 | ;;;; cycles the background color through each palette entry. 3 | 4 | ;;; This was the first test of the assembler, and doesn't use any of 5 | ;;; the fancy gimmicks added later (nor does it need to). 6 | 7 | (defpackage :nes-test-1 8 | (:use :common-lisp :asm6502 :6502 :6502-modes :asm6502-nes :asm6502-utility)) 9 | 10 | (in-package :nes-test-1) 11 | 12 | (write-ines 13 | "/tmp/nes-test-1.nes" 14 | (let ((*context* (make-instance 'basic-context :address #x8000)) 15 | (color (zp 0))) 16 | 17 | ;; Program Entry Point 18 | (set-label 'entry-point) 19 | (sei) ; Disable interrupts 20 | (cld) 21 | (ldx (imm #xFF)) ; Init stack pointer 22 | (txs) 23 | (lda (imm 3)) 24 | (sta color) 25 | 26 | ;; Configure PPU 27 | (lda (imm #b10000000)) ; Enable VBlank NMI 28 | (sta (mem +ppu-cr1+)) 29 | (lda (imm #b00000000)) ; Display off 30 | (sta (mem +ppu-cr2+)) 31 | (jmp (mem *origin*)) ; Spin. 32 | 33 | ;; VBlank Handler 34 | (set-label 'vblank-handler) 35 | (lda (mem +ppu-status+)) ; Clear NMI, reset high/low state 36 | (lda (imm #x3F)) ; Program address #x3F00 37 | (sta (mem +vram-addr+)) ; ..write MSB 38 | (lda (imm #x00)) 39 | (sta (mem +vram-addr+)) ; ..write LSB 40 | 41 | (inc color) ; Increment and load color 42 | (lda color) 43 | 44 | (lsr) ; Shift right two bits, so each 45 | (lsr) ; color appears for four frames. 46 | (sta (mem +vram-io+)) ; Write color to palete. 47 | 48 | (poke #x3F +vram-addr+) ; Reset address due to palette latching. 49 | (poke #x00 +vram-addr+) 50 | (rti) 51 | 52 | ;; IRQ/Break Handler 53 | (set-label 'brk-handler) 54 | (rti) 55 | 56 | ;; Interrupt Vectors 57 | (advance-to +nmi-vector+) 58 | (dw (label 'vblank-handler)) ;; NMI 59 | (dw (label 'entry-point)) ;; RESET 60 | (dw (label 'brk-handler)) ;; BRK/IRQ 61 | 62 | (link *context*))) 63 | -------------------------------------------------------------------------------- /hacks/nes-test-2.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Another NES test. This one displays a page from the character ROM 2 | ;;;; and several gradient bars, with the intent of judging how 3 | ;;;; convincingly you can use interlacing to blend between the four 4 | ;;;; available palette colors. Turns out that blending between 5 | ;;;; adjacent hues almost always looks good, but blending between 6 | ;;;; luminances always looks somewhat flickery (depending on hue). 7 | ;;;; Pressing the direction pad changes the base hue. Tends to flicker 8 | ;;;; badly on emulators that aren't locked to the display refresh. 9 | 10 | (defpackage :nes-test-2 11 | (:use :common-lisp :asm6502 :6502 :6502-modes :asm6502-nes :asm6502-utility)) 12 | 13 | (in-package :nes-test-2) 14 | 15 | (defmacro emitting-program ((filename &rest rom-args) &body body) 16 | `(write-ines 17 | ,filename 18 | (link 19 | (let ((*context* (make-instance 'basic-context :address #x8000))) 20 | ,@body 21 | *context*)) 22 | ,@rom-args)) 23 | 24 | (defvar *path* #.*compile-file-pathname*) 25 | 26 | (defparameter *ticker* (zp 0)) 27 | (defparameter *color* (zp 1)) 28 | (defparameter *lastj* (zp 3)) 29 | (defparameter *jtmp* (zp 2)) 30 | 31 | (emitting-program ("/tmp/nes-test-2.nes" 32 | :chr (binary-file (merge-pathnames "test2.chr" *path*))) 33 | (set-label 'reset) 34 | (sei) 35 | (ldx (imm #xFF)) 36 | (txs) 37 | (poke 0 *color*) 38 | (sta *lastj*) 39 | 40 | ;; Enable VBI and let PPU warm up 41 | (poke #b10010000 +ppu-cr1+) 42 | (poke #b00000000 +ppu-cr2+) 43 | (jsr (mem (label 'wait-for-vblank))) 44 | (jsr (mem (label 'wait-for-vblank))) 45 | (poke #b00010000 +ppu-cr1+) 46 | 47 | ;; Clear name tables 48 | (ppuaddr #x2000) 49 | (lda (imm #xff)) 50 | (ldy (imm 8)) 51 | (set-label :outer) 52 | (ldx (imm 0)) 53 | (set-label :loop) 54 | (sta (mem +vram-io+)) 55 | (inx) 56 | (bne (rel :loop)) 57 | (dey) 58 | (bne (rel :outer)) 59 | 60 | ;; Zero attribute table 61 | (ppuaddr #x23C0) 62 | (lda (imm 0)) 63 | (ldx (imm 60)) 64 | (set-label :loop) 65 | (sta (mem +vram-io+)) 66 | (dex) 67 | (bne (rel :loop)) 68 | 69 | ;; Display something 70 | (ppuaddr #x2063) 71 | (ldx (imm 10)) 72 | (set-label :loop) 73 | (txa) 74 | (clc) 75 | (adc (imm #xCF)) 76 | (sta (mem +vram-io+)) 77 | (dex) 78 | (bne (rel :loop)) 79 | 80 | ;; Show the character rom 81 | (lda (mem +ppu-status+)) 82 | (ldx (imm 0)) 83 | (set-label :loop) 84 | (txa) 85 | (anda (imm 15)) 86 | (asif :zero 87 | (txa) 88 | (asl) 89 | (lda (imm 0)) 90 | (adc (imm #x21)) 91 | (sta (mem +vram-addr+)) 92 | (txa) 93 | (asl) 94 | (clc) 95 | (adc (imm 8)) 96 | (sta (mem +vram-addr+))) 97 | (stx (mem +vram-io+)) 98 | (inx) 99 | (bne (rel :loop)) 100 | 101 | ;; Draw gradient stripes 102 | (poke #b00000100 +ppu-cr1+) ; vertical write mode 103 | (ldy (imm 6)) 104 | (clc) 105 | (set-label :loop) 106 | (poke #x20 +vram-addr+) 107 | (tya) 108 | (adc (imm #x59)) 109 | (sta (mem +vram-addr+)) 110 | (jsr (mem (label 'write-stripe))) 111 | (dey) 112 | (bne (rel :loop)) 113 | (poke #b00000000 +ppu-cr1+) ; horizontal write mode 114 | (ppuaddr (+ #x23c0 0 6)) ; alternating attributes 115 | (poke #b01000000 +vram-io+) 116 | (poke #b00100000 +vram-io+) 117 | (ppuaddr (+ #x23c0 8 6)) ; alternating attributes 118 | (poke #b01000100 +vram-io+) 119 | (poke #b00101110 +vram-io+) 120 | (ppuaddr (+ #x23c0 16 6)) 121 | (poke #b01000100 +vram-io+) 122 | (poke #b00101110 +vram-io+) 123 | (ppuaddr (+ #x23c0 24 6)) 124 | (poke #b01000100 +vram-io+) 125 | (poke #b00001110 +vram-io+) 126 | 127 | ;; Select character bank, reset scroll, turn on the display 128 | ;;(poke 0 #x8000) 129 | ;;(poke 20 #x8001) 130 | ;;(poke 1 #x8000) 131 | ;;(poke 21 #x8001) 132 | 133 | (lda (imm 0)) 134 | (pha) 135 | 136 | (set-label :mainloop) 137 | (jsr (mem (label 'configure-ppu))) 138 | (jsr (mem (label 'wait-for-vblank))) 139 | (jsr (mem (label 'process-input))) 140 | (jsr (mem (label 'program-palette))) 141 | 142 | (pla) 143 | (eor (imm 1)) 144 | (pha) 145 | 146 | (asif :zero 147 | (clc) 148 | (ppuaddr #x3F0D) 149 | (poke *color* +vram-io+) 150 | (adc (imm 16)) 151 | (sta (mem +vram-io+)) 152 | (adc (imm 16)) 153 | (sta (mem +vram-io+)) 154 | 155 | (ppuaddr #x3F09) 156 | (lda *color*) 157 | (adc (imm 1)) 158 | (anda (imm 63)) 159 | (jsr (mem (label 'ramp3))) 160 | 161 | :else 162 | (ppuaddr #x3F0D) 163 | (lda *color*) 164 | (jsr (mem (label 'ramp3))) 165 | (ppuaddr #x3F09) 166 | (lda *color*) 167 | (jsr (mem (label 'ramp3)))) 168 | 169 | (jmp (mem (label :mainloop))) 170 | 171 | ;;;; ---------------------------------------------------------------- 172 | 173 | ;;; Read joypad 174 | (set-label 'process-input) 175 | (poke 1 +joypad-1+) 176 | (poke 0 +joypad-1+) 177 | (loop repeat 8 do (lda (mem +joypad-1+)) (lsr) (rol *jtmp*)) 178 | (lda *jtmp*) 179 | (tax) 180 | (and 15) 181 | (sta *color*) 182 | (inc *color*) 183 | (eor *lastj*) 184 | ;; Test A Button 185 | (asl) 186 | (tay) 187 | (asif :carry 188 | (lda *lastj*) 189 | (asif :positive 190 | (brk) (db 1))) 191 | ;; Test B Button 192 | (tya) 193 | (asl) 194 | (asif :carry 195 | (lda *lastj*) 196 | (asl) 197 | (asif :positive 198 | (brk) (db 2))) 199 | ;; Almost done. 200 | (stx *lastj*) 201 | (rts) 202 | 203 | ;;; Program palette 204 | (set-label 'program-palette) 205 | (lda (mem +ppu-status+)) 206 | (ppuaddr #x3F00) 207 | (clc) 208 | (lda *color*) 209 | (jsr (mem (label 'ramp))) 210 | (adc (imm 17)) 211 | (anda (imm 63)) ; tail call. 212 | (set-label 'ramp) 213 | (sta (mem +vram-io+)) 214 | (set-label 'ramp3) 215 | (adc (imm 16)) 216 | (sta (mem +vram-io+)) 217 | (adc (imm 16)) 218 | (sta (mem +vram-io+)) 219 | (adc (imm 16)) 220 | (sta (mem +vram-io+)) 221 | (rts) 222 | 223 | ;;; Reset PPU state at end of vblank 224 | (set-label 'configure-ppu) 225 | (lda (mem +ppu-status+)) 226 | (lda (imm 0)) 227 | (sta (mem +vram-addr+)) 228 | (sta (mem +vram-addr+)) 229 | (sta (mem +vram-scroll+)) 230 | (sta (mem +vram-scroll+)) 231 | (poke #b10000000 +ppu-cr1+) ; enable VBI, horizontal write mode 232 | (poke #b00001110 +ppu-cr2+) 233 | (rts) 234 | 235 | (set-label 'write-stripe) 236 | (clc) 237 | (ldx (imm 3)) 238 | (set-label :loop) 239 | (txa) 240 | (adc (imm #xFB)) 241 | (sta (mem +vram-io+)) 242 | (sta (mem +vram-io+)) 243 | (sta (mem +vram-io+)) 244 | (sta (mem +vram-io+)) 245 | (dex) 246 | (bne (rel :loop)) 247 | (rts) 248 | 249 | ;;; VBI handler 250 | (set-label 'vblank) 251 | (pha) 252 | (poke 0 *ticker*) 253 | (pla) 254 | (rti) 255 | 256 | ;;; Wait for vertical blank 257 | (set-label 'wait-for-vblank) 258 | (poke 1 *ticker*) 259 | (set-label 'wait-for-vblank-1) 260 | (lda *ticker*) 261 | (bne (rel 'wait-for-vblank-1)) 262 | (rts) 263 | 264 | (set-label 'irq) 265 | (rti) 266 | 267 | ;;; Interrupt Vectors 268 | (format t "~&Program size: ~D bytes~%" (- *origin* #x8000)) 269 | (advance-to +nmi-vector+) 270 | (dw (label 'vblank)) 271 | (dw (label 'reset)) 272 | (dw (label 'irq))) 273 | -------------------------------------------------------------------------------- /hacks/nsf-test-1.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :nsf-test-1 2 | (:use :common-lisp :6502 :6502-modes :asm6502 :asm6502-utility :asm6502-nes)) 3 | 4 | (in-package :nsf-test-1) 5 | 6 | (let ((*context* (make-instance 'basic-context))) 7 | (emit-nsf-header 1 #x8000 :init :play) 8 | (format t "~&Header is ~A bytes.~%" (length (context-code-vector *context*))) 9 | (setf *origin* #x8000) 10 | 11 | (procedure init 12 | (cld) 13 | (rts)) 14 | 15 | (procedure play 16 | (cld) 17 | (rts)) 18 | 19 | (setf (binary-file "/tmp/test1.nsf") (link *context*))) 20 | 21 | -------------------------------------------------------------------------------- /hacks/rgbi/blue.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ahefner/asm6502/802daae092f8ab2c50eb469497ee03b30474f2a7/hacks/rgbi/blue.gif -------------------------------------------------------------------------------- /hacks/rgbi/grayscale-1.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ahefner/asm6502/802daae092f8ab2c50eb469497ee03b30474f2a7/hacks/rgbi/grayscale-1.gif -------------------------------------------------------------------------------- /hacks/rgbi/grayscale-2.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ahefner/asm6502/802daae092f8ab2c50eb469497ee03b30474f2a7/hacks/rgbi/grayscale-2.gif -------------------------------------------------------------------------------- /hacks/rgbi/grayscale.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ahefner/asm6502/802daae092f8ab2c50eb469497ee03b30474f2a7/hacks/rgbi/grayscale.gif -------------------------------------------------------------------------------- /hacks/rgbi/grayscale.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage :rgbi 3 | (:use :common-lisp :6502 :6502-modes :asm6502 :asm6502-utility :asm6502-nes)) 4 | 5 | (in-package :rgbi) 6 | 7 | (defvar *path* #.*compile-file-pathname*) 8 | 9 | (defparameter *mmc3-bank-config* 0 10 | "Used for upper bits of writes to $8000 via MMC3-BANK function") 11 | 12 | (defun mmc3-bank (bank value) 13 | (poke (logior *mmc3-bank-config* bank) #x8000) 14 | (poke value #x8001)) 15 | 16 | (let* ((*context* (make-instance 'basic-context :address #x8000)) 17 | (*default-pathname-defaults* *path*) 18 | (vblank-flag (zp 16)) 19 | (bg-bank (zp 17))) 20 | 21 | ;; --- ENTRY POINT (assemble in last PRG bank) --- 22 | (advance-to #xE000) 23 | (set-label 'reset) 24 | 25 | (sei) 26 | (cld) 27 | (poke #x40 +papu-irq-ctrl+) ; Disable APU frame IRQ 28 | (ldx (imm #xFF)) ; Init stack pointer 29 | (txs) 30 | (poke #b00000000 +ppu-cr1+) ; Disable NMI 31 | (poke #b00000000 +ppu-cr2+) ; Disable rendering 32 | (poke #b00000000 +dmc-control+) 33 | 34 | (bita (mem +ppu-status+)) ; Clear vblank flag 35 | (as/until :negative ; Loop until high (vblank) bit set 36 | (bita (mem +ppu-status+))) 37 | 38 | ;; Build empty sprite table at $0200 39 | (lda (imm #xFF)) 40 | (ldx (imm 0)) 41 | (as/until :zero 42 | (sta (abx #x0200)) 43 | (inx)) 44 | 45 | ;; Kill time while PPU warms up.. 46 | (ldy (imm 128)) 47 | (ldx (imm 0)) 48 | (as/until :zero 49 | (as/until :zero 50 | (dex)) 51 | (dey)) 52 | 53 | ;;; MMC3 init 54 | (mmc3-bank 0 0) ; PPU $0000 55 | (mmc3-bank 1 2) ; PPU $0800 56 | (mmc3-bank 2 15) ; PPU $1000 57 | (mmc3-bank 3 15) ; PPU $1400 58 | (mmc3-bank 4 15) ; PPU $1800 59 | (mmc3-bank 5 15) ; PPU $1C00 60 | (mmc3-bank 6 0) ; CPU $8000 61 | (mmc3-bank 7 1) ; CPU $A000 62 | (poke 0 #xE000) ; Disable IRQ 63 | 64 | ;;; -- PPU should be ready now.. build the screen contents -- 65 | 66 | (bita (mem +ppu-status+)) ; Wait for vblank again 67 | (as/until :negative 68 | (bita (mem +ppu-status+))) 69 | 70 | ;; Program palette 71 | (ppuaddr #x3F00) 72 | (loop repeat 4 do 73 | (poke #x0F +vram-io+) 74 | (poke #x2D +vram-io+) 75 | (poke #x00 +vram-io+) 76 | (poke #x3D +vram-io+)) 77 | 78 | ;; Clear nametable $2000 79 | (ppuaddr #x2000) 80 | (lda (imm 255)) ;tile # to clear nametable to 81 | (ldy (imm 30)) ; Y counts down 30 rows 82 | (as/until :zero 83 | (ldx (imm 32)) ; X counts down 32 columns 84 | (as/until :zero 85 | (sta (mem +vram-io+)) 86 | (dex)) 87 | (dey)) 88 | 89 | ;; Clear attribute table 90 | (ldx (imm 64)) 91 | (lda (imm 0)) ; First BG palette 92 | (as/until :zero 93 | (sta (mem +vram-io+))) 94 | 95 | ;; Display character rom 96 | (ppuxy 0 0) 97 | (ldy (imm 4)) 98 | (as/until :zero 99 | (ldx (imm 0)) 100 | (as/until :zero 101 | (txa) 102 | (sta (mem +vram-io+)) 103 | (inx)) 104 | (dey)) 105 | 106 | ;; Turn the screen back on 107 | (poke #b10001000 +ppu-cr1+) ; BG CHR $0000, SPR CHR $1000 108 | (jsr 'wait-vblank) 109 | (jsr 'wait-vblank) 110 | 111 | (poke 0 +vram-scroll+) 112 | (sta (mem +vram-scroll+)) 113 | (ppuaddr #x2000) 114 | 115 | (jsr 'wait-vblank) 116 | (cli) 117 | 118 | (with-label :loop 119 | 120 | (poke #x00 bg-bank) 121 | (jsr 'frame) 122 | 123 | (poke #x10 bg-bank) 124 | (jsr 'frame) 125 | 126 | (jmp (mem :loop))) 127 | 128 | 129 | (procedure frame 130 | (jsr 'next-bg-chr-bank) 131 | (poke #b10001000 +ppu-cr1+) ; BG CHR $0000, SPR CHR $1000 132 | (poke #b00001000 +ppu-cr2+) ; BG visible, SPR off, darken screen 133 | (jsr 'frame-irq-init) 134 | (jsr 'wait-vblank) 135 | (rts)) 136 | 137 | (procedure wait-vblank 138 | (lda (imm 0)) 139 | (sta vblank-flag) 140 | (as/until :not-zero 141 | (lda vblank-flag)) 142 | (rts)) 143 | 144 | ;; Program MMC IRQ counter 145 | (procedure frame-irq-init 146 | (poke 0 #xE000) ; Disable/ACK MMC3 IRQ 147 | (poke 60 #xC000) ; IRQ latch (countdown) 148 | (sta (mem #xC001)) ; Transfer IRQ latch to counter 149 | (sta (mem #xE001)) ; Enable scanline IRQ 150 | (rts)) 151 | 152 | ;; Interrupt handlers 153 | (procedure vblank-handler 154 | (inc vblank-flag) 155 | (rti)) 156 | 157 | ;; Program and increment background character bank 158 | (procedure next-bg-chr-bank 159 | (mmc3-bank 0 bg-bank) 160 | (inc bg-bank) 161 | (inc bg-bank) 162 | (emit-delay 300) 163 | (mmc3-bank 1 bg-bank) 164 | (inc bg-bank) 165 | (inc bg-bank) 166 | (rts)) 167 | 168 | ;; Scanline IRQ 169 | (procedure irq-handler 170 | (poke 0 #xE000) ; ACK / Disable IRQ 171 | ; (emit-delay 50) 172 | (jsr 'next-bg-chr-bank) 173 | ;;(poke #x88 +ppu-cr2+) ; debug 174 | (poke 60 #xC000) ; IRQ latch (countdown) 175 | (sta (mem #xC001)) ; Transfer IRQ latch to counter 176 | (poke 0 #xE001) ; Enable IRQ 177 | (rti)) 178 | 179 | ;; Interrupt vectors 180 | (advance-to +nmi-vector+) 181 | (dw (label 'vblank-handler)) 182 | (dw (label 'reset)) 183 | (dw (label 'irq-handler)) 184 | 185 | ;; Generate output file (TNROM, 32K PRG / 32K CHR) 186 | (write-ines "/tmp/rgbi.nes" 187 | (link *context*) 188 | :mapper 4 189 | :chr (concatenate 'vector 190 | (ichr:encode-gif "grayscale-1.gif") 191 | (ichr:encode-gif "grayscale-2.gif")))) 192 | -------------------------------------------------------------------------------- /hacks/rgbi/green.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ahefner/asm6502/802daae092f8ab2c50eb469497ee03b30474f2a7/hacks/rgbi/green.gif -------------------------------------------------------------------------------- /hacks/rgbi/red.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ahefner/asm6502/802daae092f8ab2c50eb469497ee03b30474f2a7/hacks/rgbi/red.gif -------------------------------------------------------------------------------- /hacks/rgbi/rgbi.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage :rgbi 3 | (:use :common-lisp :6502 :6502-modes :asm6502 :asm6502-utility :asm6502-nes)) 4 | 5 | (in-package :rgbi) 6 | 7 | (defvar *path* #.*compile-file-pathname*) 8 | 9 | (defparameter *mmc3-bank-config* 0 10 | "Used for upper bits of writes to $8000 via MMC3-BANK function") 11 | 12 | (defun mmc3-bank (bank value) 13 | (poke (logior *mmc3-bank-config* bank) #x8000) 14 | (poke value #x8001)) 15 | 16 | (let* ((*context* (make-instance 'basic-context :address #x8000)) 17 | (*default-pathname-defaults* *path*) 18 | (vblank-flag (zp 16)) 19 | (bg-bank (zp 17))) 20 | 21 | ;; --- ENTRY POINT (assemble in last PRG bank) --- 22 | (advance-to #xE000) 23 | (set-label 'reset) 24 | 25 | (sei) 26 | (cld) 27 | (poke #x40 +papu-irq-ctrl+) ; Disable APU frame IRQ 28 | (ldx (imm #xFF)) ; Init stack pointer 29 | (txs) 30 | (poke #b00000000 +ppu-cr1+) ; Disable NMI 31 | (poke #b00000000 +ppu-cr2+) ; Disable rendering 32 | (poke #b00000000 +dmc-control+) 33 | 34 | (bita (mem +ppu-status+)) ; Clear vblank flag 35 | (as/until :negative ; Loop until high (vblank) bit set 36 | (bita (mem +ppu-status+))) 37 | 38 | ;; Build empty sprite table at $0200 39 | (lda (imm #xFF)) 40 | (ldx (imm 0)) 41 | (as/until :zero 42 | (sta (abx #x0200)) 43 | (inx)) 44 | 45 | ;; Kill time while PPU warms up.. 46 | (ldy (imm 128)) 47 | (ldx (imm 0)) 48 | (as/until :zero 49 | (as/until :zero 50 | (dex)) 51 | (dey)) 52 | 53 | ;;; MMC3 init 54 | (mmc3-bank 0 0) ; PPU $0000 55 | (mmc3-bank 1 2) ; PPU $0800 56 | (mmc3-bank 2 15) ; PPU $1000 57 | (mmc3-bank 3 15) ; PPU $1400 58 | (mmc3-bank 4 15) ; PPU $1800 59 | (mmc3-bank 5 15) ; PPU $1C00 60 | (mmc3-bank 6 0) ; CPU $8000 61 | (mmc3-bank 7 1) ; CPU $A000 62 | (poke 0 #xE000) ; Disable IRQ 63 | 64 | ;;; -- PPU should be ready now.. build the screen contents -- 65 | 66 | (bita (mem +ppu-status+)) ; Wait for vblank again 67 | (as/until :negative 68 | (bita (mem +ppu-status+))) 69 | 70 | ;; Clear nametable $2000 71 | (ppuaddr #x2000) 72 | (lda (imm 255)) ;tile # to clear nametable to 73 | (ldy (imm 30)) ; Y counts down 30 rows 74 | (as/until :zero 75 | (ldx (imm 32)) ; X counts down 32 columns 76 | (as/until :zero 77 | (sta (mem +vram-io+)) 78 | (dex)) 79 | (dey)) 80 | 81 | ;; Display character rom 82 | (ppuxy 0 0) 83 | (ldy (imm 4)) 84 | (as/until :zero 85 | (ldx (imm 0)) 86 | (as/until :zero 87 | (txa) 88 | (sta (mem +vram-io+)) 89 | (inx)) 90 | (dey)) 91 | 92 | ;; Clear attribute table 93 | (ppuaddr #x23C0) 94 | (ldx (imm 64)) 95 | (lda (imm 0)) ; First BG palette 96 | (as/until :zero 97 | (sta (mem +vram-io+)) 98 | (dex)) 99 | 100 | ;; Program different palette (DEBUG) 101 | (ppuaddr #x3F00) 102 | (dolist (color '(#xF #x07 #x17 #x27 103 | #xF #x07 #x17 #x27 104 | #xF #x07 #x17 #x27 105 | #xF #x07 #x17 #x27)) 106 | (poke color +vram-io+)) 107 | 108 | ;; Turn the screen back on 109 | (poke #b10001000 +ppu-cr1+) ; BG CHR $0000, SPR CHR $1000 110 | (poke #b00001000 +ppu-cr2+) ; BG visible, SPR off 111 | (jsr 'wait-vblank) 112 | (jsr 'wait-vblank) 113 | 114 | (poke 0 +vram-scroll+) 115 | (sta (mem +vram-scroll+)) 116 | (ppuaddr #x2000) 117 | 118 | (jsr 'wait-vblank) 119 | (cli) 120 | 121 | (with-label :loop 122 | 123 | ;; Red 124 | (jsr 'wait-vblank) 125 | (ppuaddr #x3F00) 126 | (dolist (color '(#xF #x05 #x15 #x25)) 127 | (poke color +vram-io+)) 128 | (poke #x00 bg-bank) 129 | (jsr 'frame) 130 | 131 | ;; Green 132 | (jsr 'wait-vblank) 133 | (ppuaddr #x3F00) 134 | (dolist (color '(#xF #x09 #x19 #x29)) 135 | (poke color +vram-io+)) 136 | (poke #x10 bg-bank) 137 | (jsr 'frame) 138 | 139 | ;; Blue 140 | (jsr 'wait-vblank) 141 | (ppuaddr #x3F00) 142 | (dolist (color '(#xF #x01 #x11 #x21)) 143 | (poke color +vram-io+)) 144 | (poke #x20 bg-bank) 145 | (jsr 'frame) 146 | 147 | (jmp (mem :loop))) 148 | 149 | 150 | (procedure frame 151 | (ppuaddr #x2000) ; Reset PPU address after palette update 152 | (jsr 'next-bg-chr-bank) 153 | (poke #b10001000 +ppu-cr1+) ; BG CHR $0000, SPR CHR $1000 154 | (poke #b00001000 +ppu-cr2+) ; BG visible, SPR off 155 | (jsr 'frame-irq-init) 156 | (rts)) 157 | 158 | (procedure wait-vblank 159 | (lda (imm 0)) 160 | (sta vblank-flag) 161 | (as/until :not-zero 162 | (lda vblank-flag)) 163 | (rts)) 164 | 165 | ;; Program MMC IRQ counter 166 | (procedure frame-irq-init 167 | (poke 0 #xE000) ; Disable/ACK MMC3 IRQ 168 | (poke 60 #xC000) ; IRQ latch (countdown) 169 | (sta (mem #xC001)) ; Transfer IRQ latch to counter 170 | (sta (mem #xE001)) ; Enable scanline IRQ 171 | (rts)) 172 | 173 | ;; Interrupt handlers 174 | (procedure vblank-handler 175 | (inc vblank-flag) 176 | (rti)) 177 | 178 | ;; Program and increment background character bank 179 | (procedure next-bg-chr-bank 180 | (mmc3-bank 0 bg-bank) 181 | (inc bg-bank) 182 | (inc bg-bank) 183 | (emit-delay 300) 184 | (mmc3-bank 1 bg-bank) 185 | (inc bg-bank) 186 | (inc bg-bank) 187 | (rts)) 188 | 189 | ;; Scanline IRQ 190 | (procedure irq-handler 191 | (poke 0 #xE000) ; ACK / Disable IRQ 192 | ; (emit-delay 50) 193 | (jsr 'next-bg-chr-bank) 194 | ;;(poke #x88 +ppu-cr2+) ; debug 195 | (poke 60 #xC000) ; IRQ latch (countdown) 196 | (sta (mem #xC001)) ; Transfer IRQ latch to counter 197 | (poke 0 #xE001) ; Enable IRQ 198 | (rti)) 199 | 200 | ;; Interrupt vectors 201 | (advance-to +nmi-vector+) 202 | (dw (label 'vblank-handler)) 203 | (dw (label 'reset)) 204 | (dw (label 'irq-handler)) 205 | 206 | ;; Generate output file (TNROM, 32K PRG / 32K CHR) 207 | (write-ines "/tmp/rgbi.nes" 208 | (link *context*) 209 | :mapper 4 210 | :chr (concatenate 'vector 211 | (ichr:encode-gif "red.gif") 212 | (ichr:encode-gif "green.gif") 213 | (ichr:encode-gif "blue.gif") 214 | (ichr:encode-gif "red.gif")))) 215 | -------------------------------------------------------------------------------- /hacks/ryden.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ahefner/asm6502/802daae092f8ab2c50eb469497ee03b30474f2a7/hacks/ryden.gif -------------------------------------------------------------------------------- /hacks/test1/bg0.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ahefner/asm6502/802daae092f8ab2c50eb469497ee03b30474f2a7/hacks/test1/bg0.gif -------------------------------------------------------------------------------- /hacks/test1/spr0.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ahefner/asm6502/802daae092f8ab2c50eb469497ee03b30474f2a7/hacks/test1/spr0.gif -------------------------------------------------------------------------------- /hacks/test1/sprite-test.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage :sprite-test-1 3 | (:use :common-lisp 4 | :6502 5 | :6502-modes 6 | :asm6502 7 | :asm6502-utility 8 | :asm6502-nes)) 9 | 10 | (in-package :sprite-test-1) 11 | 12 | (defvar *path* #.*compile-file-pathname*) 13 | (defun asset-path (filename) (merge-pathnames filename *path*)) 14 | 15 | ;; I'm going to try this slightly differently this time.. 16 | (defparameter *global-context* (make-instance 'basic-context :address #x8000)) 17 | (setf *context* *global-context*) ; yuck. 18 | 19 | ;;;; Memory map 20 | 21 | ;;; 0000-0020: Temporaries for leaf functions (caller saved if used in non-leaves) 22 | (defconstant +temp-start+ 0) 23 | (defconstant +temp-end+ #x20) 24 | 25 | (defparameter current-ent-map-x (zp #xD0)) 26 | (defparameter current-ent-map-y (zp #xD1)) 27 | (defparameter current-ent-idx (zp #xD2)) 28 | 29 | (defparameter status-update-vector (wordvar #xE0) 30 | "Status bar updates by END-FRAME are done by setting this code pointer.") 31 | 32 | (defparameter sprite-x (zp #xF0)) 33 | (defparameter sprite-y (zp #xF1)) 34 | (defparameter *shadow-cr1* (zp #xF2)) 35 | (defparameter *shadow-cr2* (zp #xF3)) 36 | (defparameter *shadow-scroll-x* (zp #xF4)) 37 | (defparameter *shadow-scroll-y* (zp #xF5)) 38 | 39 | (defparameter *frame-counter* (zp #xFD) 40 | "Incremented each frame by NMI handler") 41 | 42 | ;;(defparameter *sprite-count* (zp #xFD)) 43 | (defparameter *oamidx* (zp #xFE)) 44 | (defparameter vblank-flag (zp #xFF)) 45 | 46 | (defparameter *oam-shadow* #x0200) 47 | 48 | ;;; Game state 49 | 50 | ;;; Game map is a 14x12 board 51 | 52 | ;;; ENTITY MAP - contains unit type and owner 53 | ;;; 76543210 54 | ;;; ttttttxx 55 | ;;; x - Owner (player 0..3) 56 | ;;; t - Element type (0 is invalid) 57 | ;;; Value of zero means no entity 58 | 59 | (defconstant +map-width+ 14) 60 | (defconstant +map-height+ 12) 61 | (defconstant +map-size+ (* +map-width+ +map-height+)) 62 | 63 | (defconstant +entity-map+ #x300) 64 | 65 | ;;;; Etc. 66 | 67 | (defparameter *character-mapping* 68 | "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!@#$%^&*()`~-_+=[]{};:'\",.<>/?\\| ") 69 | 70 | (defun map-string (string) 71 | (map 'vector (lambda (char) (+ #xA0 (position char *character-mapping*))) string)) 72 | 73 | 74 | 75 | ;;;; Code 76 | 77 | (defun oam-flag-value (flag) 78 | (let ((tmp (assoc flag '((:fliph . 64) 79 | (:flipv . 128) 80 | (:fg . 0) 81 | (:bg . 32))))) 82 | (when (null tmp) 83 | (error "Unknown flag ~A" flag)) 84 | (cdr tmp))) 85 | 86 | (defmacro defsprite (name &body body) 87 | `(procedure ,name ;;',(list :sprite name) 88 | (ldy *oamidx*) 89 | (mapcar 90 | (lambda (spec) 91 | (destructuring-bind (x y tile palette &rest flags) spec 92 | ;; Write Y coordinate 93 | (lda sprite-y) 94 | (unless (zerop y) 95 | (clc) 96 | (adc (imm y))) 97 | (sta (aby *oam-shadow*)) 98 | (iny) 99 | ;; Write tile index 100 | (lda (imm tile)) 101 | (sta (aby *oam-shadow*)) 102 | (iny) 103 | ;; Write flags 104 | (lda (imm (logior palette (reduce #'+ (mapcar #'oam-flag-value flags))))) 105 | (sta (aby *oam-shadow*)) 106 | (iny) 107 | ;; Write X coordinate 108 | (lda sprite-x) 109 | (unless (zerop x) 110 | (clc) 111 | (adc (imm x))) 112 | (sta (aby *oam-shadow*)) 113 | (iny))) 114 | ',body) 115 | ;; Experiment for sprite muxing: 116 | (tya) 117 | ;; (clc) 118 | (adc (imm (ash (- 11 1) 2))) ; Subtract one, because we already incremented.. 119 | (sta *oamidx*) 120 | ;; ..instead of.. 121 | ;; (sty *oamidx*) 122 | (rts))) 123 | 124 | (defsprite (sage f 0) 125 | (0 0 #x00 1) 126 | (8 0 #x01 1) 127 | (0 8 #x10 0) 128 | (8 8 #x11 0)) 129 | 130 | (defsprite (sage f 1) 131 | (0 0 #x00 1) 132 | (8 0 #x01 1) 133 | (8 8 #x10 0 :fliph) 134 | (0 8 #x11 0 :fliph)) 135 | 136 | (defsprite (wiz f 0) 137 | (0 0 #x02 0) 138 | (8 0 #x03 0) 139 | (0 8 #x12 0) 140 | (8 8 #x13 0)) 141 | 142 | (procedure reset 143 | (sei) 144 | (cld) 145 | (poke #b00010000 +ppu-cr1+) ; NMI off during init. 146 | (poke #b00000000 +ppu-cr2+) ; Do turn the screen off too.. 147 | (poke #x40 +papu-irq-ctrl+) 148 | (ldx (imm #xFF)) ; Set stack pointer 149 | (txs) 150 | 151 | ;; Init sound hardware 152 | (poke 0 #x4015) ; Silence all channels 153 | (poke #x40 #x4017) ; Disable IRQ 154 | 155 | (bita (mem +ppu-status+)) ; clear vblank flag (reset glitch) 156 | (as/until :negative (bita (mem +ppu-status+))) ; PPU warmup interval 157 | (as/until :negative (bita (mem +ppu-status+))) ; (two frames) 158 | 159 | (lda (mem +ppu-status+)) ; Clear vblank flag before enabling NMI! 160 | (poke #b10001000 +ppu-cr1+) ; Enable NMI 161 | 162 | ;; Reset background 163 | (jsr 'wait-for-vblank) ; Rendering is off but just to be safe.. (?..) 164 | (jsr 'reset-background) 165 | 166 | ;; Palette init 167 | (jsr 'wait-for-vblank) 168 | (ppuaddr #x3F00) 169 | (let ((bg #x1B)) 170 | (dolist (color (list bg #x1D #x3D #x30 bg #x03 #x13 #x23 171 | bg #x2D #x3D #x30 bg #x05 #x15 #x25 172 | bg #x1d #x15 #x37 bg #x1d #x13 #x37)) 173 | (poke color +vram-io+))) 174 | 175 | (jsr 'reset-frame-vectors) 176 | 177 | ;; Main loop - wait for vblank, reset PPU registers, do sprite DMA. 178 | (with-label :loop 179 | ;; FIXME: sprite chr table address behaving backward vs what I expect.. 180 | (poke #b10010000 *shadow-cr1*) 181 | (poke #b00011110 *shadow-cr2*) 182 | (poke 0 *shadow-scroll-x*) 183 | (poke 0 *shadow-scroll-y*) 184 | 185 | (lda (imm 80)) 186 | (cmp *frame-counter*) 187 | (asif :negative 188 | (pokeword (label 'test-status-update) status-update-vector) 189 | :else 190 | (pokeword (label 'test-status-update-2) status-update-vector)) 191 | 192 | (jsr 'render-sprites) 193 | 194 | (jsr 'end-frame) 195 | 196 | (jmp (mem :loop)))) 197 | 198 | (procedure reset-background 199 | ;; Fill first name table screen 200 | (lda (mem +ppu-status+)) ; Reset address latch 201 | (ppuaddr #x2000) 202 | (lda (imm 0)) 203 | (ldy (imm 4)) 204 | (as/until :zero 205 | (ldx (imm 0)) 206 | (as/until :zero 207 | (sta (mem +vram-io+)) 208 | (dex)) 209 | (dey)) 210 | (ppuaddr #x23C0) ; Attribute table 211 | (lda (imm 0)) 212 | (ldx (imm 64)) 213 | (as/until :zero 214 | (sta (mem +vram-io+)) 215 | (dex)) 216 | ;; Fill second screen 217 | (ppuaddr #x2400) 218 | (lda (imm 3)) ; Distinguish color since it should be hidden now 219 | (ldy (imm 4)) 220 | (as/until :zero 221 | (ldx (imm 0)) 222 | (as/until :zero 223 | (sta (mem +vram-io+)) 224 | (dex)) 225 | (dey)) 226 | (ppuaddr #x27C0) ; Attribute table 227 | (lda (imm 0)) 228 | (ldx (imm 64)) 229 | (as/until :zero 230 | (sta (mem +vram-io+)) 231 | (dex)) 232 | (jsr 'redraw-borders) 233 | (rts)) 234 | 235 | (procedure redraw-borders 236 | (flet ((draw (x y repeat value) 237 | (assert (<= 0 x 31)) 238 | (assert (<= 0 y 29)) 239 | (assert (< 0 repeat 256)) 240 | (ppuxy x y) 241 | (cond 242 | ((= 1 repeat) 243 | (poke value +vram-io+)) 244 | (t 245 | (lda (imm value)) 246 | (ldx (imm repeat)) 247 | (as/until :zero 248 | (sta (mem +vram-io+)) 249 | (dex)))))) 250 | (poke #x00 +ppu-cr1+) ; Horizontal write mode 251 | (lda (mem +ppu-status+)) 252 | ;; Status bar 253 | (draw 0 0 32 1) 254 | (draw 0 1 32 5) 255 | (draw 0 3 32 4) 256 | 257 | (poke #x84 +ppu-cr1+) ; Vertical write mode 258 | (draw 0 0 30 1) 259 | (draw 1 0 30 1) 260 | (draw 30 0 30 1) 261 | (draw 31 0 30 1) 262 | 263 | ;;(draw 1 4 26 #x10) 264 | 265 | (poke #x80 +ppu-cr1+) ; Return to horizontal write mode 266 | 267 | ;; Bevel edges of status bar 268 | (draw 1 1 1 11) 269 | (draw 1 2 1 8) 270 | (draw 1 3 1 7) 271 | (draw 30 1 1 12) 272 | (draw 30 2 1 9) 273 | (draw 30 3 1 10) 274 | ) 275 | (rts)) 276 | 277 | (procedure end-frame 278 | "Complete processing for one frame. Move sprites, do pending VRAM writes, etc." 279 | (jsr 'wait-for-vblank) 280 | ;; If sprites are enabled, do DMA transfer 281 | (lda (imm #b00010000)) ; Bit 4 - sprite enable bit 282 | (bita *shadow-cr2*) 283 | (asif :not-zero 284 | (poke 0 +spr-addr+) 285 | (poke (msb *oam-shadow*) +sprite-dma+)) 286 | (poke *shadow-cr1* +ppu-cr1+) 287 | (poke *shadow-cr2* +ppu-cr2+) 288 | (lda (mem +ppu-status+)) ; Reset address latch 289 | 290 | (jmp status-update-vector) 291 | (set-label :continue-from-status-update) ; Default (idle) handler jumps here to try next vector 292 | 293 | 294 | (set-label :finish-vram-updates) ; If we update VRAM, handler jumps here (we may be out of cycles for additional updates) 295 | (lda (mem +ppu-status+)) ; Reset address latch 296 | (poke *shadow-scroll-x* +vram-scroll+) 297 | (poke *shadow-scroll-y* +vram-scroll+) 298 | (rts) 299 | 300 | (set-label 'no-status-update *global-context*) 301 | (jmp (mem :continue-from-status-update)) 302 | 303 | (set-label 'test-status-update *global-context*) 304 | (ppuxy 2 2) 305 | (loop for code across (map-string "All work and no play...") do (poke code +vram-io+)) 306 | (pokeword (label 'no-status-update) status-update-vector) 307 | (jmp (mem :continue-from-status-update)) 308 | 309 | (set-label 'test-status-update-2 *global-context*) 310 | (ppuxy 2 2) 311 | (loop for code across (map-string "..makes Jack a dull boy.") do (poke code +vram-io+)) 312 | (pokeword (label 'no-status-update) status-update-vector) 313 | (jmp (mem :continue-from-status-update))) 314 | 315 | (procedure reset-frame-vectors 316 | "Call this before first call to END-FRAME, to initialize shadows and vectors." 317 | (pokeword (label 'no-status-update) status-update-vector) 318 | (rts)) 319 | 320 | (procedure reset-sprites 321 | (ldx (imm 0)) 322 | (lda (imm 255)) 323 | (as/until :zero 324 | (sta (abx *oam-shadow*)) 325 | (dex)) 326 | (rts)) 327 | 328 | (procedure wait-for-vblank 329 | (poke 0 vblank-flag) 330 | (as/until :not-zero (lda vblank-flag)) 331 | (rts)) 332 | 333 | (procedure brk-handler (rti)) 334 | 335 | (procedure vblank-handler 336 | (php) 337 | (inc vblank-flag) 338 | (inc *frame-counter*) 339 | (plp) 340 | (rti)) 341 | 342 | ;;;; Gameplay 343 | 344 | (procedure reset-game-map 345 | (ldx (imm (1- +map-size+))) 346 | (lda (imm 0)) 347 | (as/until :negative 348 | (sta (abx +entity-map+)) 349 | (dex)) 350 | (rts)) 351 | 352 | (procedure render-sprites 353 | (dotimes (i 1000) (nop)) 354 | (brk) (db 7) 355 | ;; FIXME: Clearing OAM shadow in advance is expensive (~23 lines). 356 | ;; Better to count sprites during render and clear the unused ones in a last pass. 357 | (jsr 'reset-sprites) 358 | (ldy (imm 0)) ; Local ent idx counter 359 | (lda (imm 0)) 360 | (sta current-ent-idx) 361 | (sta current-ent-map-y) 362 | (poke 32 sprite-y) 363 | (with-label :row-loop 364 | (poke 16 sprite-x) 365 | (poke 0 current-ent-map-x) 366 | 367 | (brk) (db 0) 368 | 369 | (with-label :col-loop 370 | ;;(do something) 371 | 372 | 373 | 374 | 375 | (iny) ; Next ent index 376 | 377 | (clc) ; Next X coordinate (on screen) 378 | (lda (imm 16)) 379 | (adc sprite-x) 380 | (inc current-ent-map-x) ; Next X index (from 0) 381 | (lda (imm +map-width+)) 382 | (cmp current-ent-map-x) 383 | (bne :col-loop) 384 | 385 | ;; End of column, increment Y vars 386 | (clc) 387 | (lda (imm 16)) 388 | (adc sprite-y) 389 | (inc current-ent-map-y) 390 | (cpy (imm +map-size+)) 391 | (beq :break) 392 | (jmp (mem :row-loop)))) 393 | 394 | (set-label :break) 395 | (brk) (db 2) 396 | (rts)) 397 | 398 | 399 | ;;;; End of program 400 | 401 | (print (list :program-end *origin* 402 | :space-used (- *origin* #x8000) 403 | :space-remaining (- #xFFFA *origin*))) 404 | 405 | ;;;; Interrupt vectors 406 | 407 | (advance-to +nmi-vector+) 408 | (dw (label 'vblank-handler)) 409 | (dw (label 'reset)) 410 | (dw (label 'brk-handler)) 411 | 412 | ;;;; Write ROM image 413 | 414 | (write-ines "/tmp/sprite1.nes" 415 | (link *context*) 416 | :mirror-mode :vertical 417 | :chr (concatenate 'vector 418 | (ichr:encode-chr (ichr:read-gif (asset-path "bg0.gif"))) 419 | (ichr:encode-chr (ichr:read-gif (asset-path "spr0.gif"))))) 420 | -------------------------------------------------------------------------------- /hacks/test2.chr: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ahefner/asm6502/802daae092f8ab2c50eb469497ee03b30474f2a7/hacks/test2.chr -------------------------------------------------------------------------------- /hacks/test2m.chr: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ahefner/asm6502/802daae092f8ab2c50eb469497ee03b30474f2a7/hacks/test2m.chr -------------------------------------------------------------------------------- /ichr.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem :ichr 2 | :name "iCHR" 3 | :description "NES character bitmap converter" 4 | :author "Andy Hefner " 5 | :license "MIT-style license" 6 | :version "1.0.0" 7 | :depends-on (:asm6502 :skippy) 8 | :serial t 9 | :components ((:file "ichr"))) 10 | -------------------------------------------------------------------------------- /ichr.lisp: -------------------------------------------------------------------------------- 1 | (defpackage ichr 2 | (:use common-lisp) 3 | (:import-from asm6502 binary-file) 4 | (:export #:decode-chr #:encode-chr #:encode-gif 5 | #:write-gif #:read-gif)) 6 | 7 | (in-package :ichr) 8 | 9 | ;;;; NES character bitmap converter. 10 | 11 | (defun decode-chr (array) 12 | (loop with num-tiles = (truncate (length array) 16) 13 | with columns = 16 14 | with rows = (ceiling num-tiles columns) 15 | with output = (make-array (list (* 8 rows) (* 8 columns)) 16 | :initial-element 0 17 | :element-type '(unsigned-byte 8)) 18 | for tile from 0 below num-tiles 19 | as otx = (* 8 (mod tile columns)) 20 | as oty = (* 8 (truncate tile columns)) 21 | do 22 | (dotimes (y 8) 23 | (dotimes (x 8) 24 | (setf (aref output (+ oty y) (+ otx x)) 25 | (logior 26 | (ldb (byte 1 (- 7 x)) (aref array (+ (* tile 16) y))) 27 | (ash (ldb (byte 1 (- 7 x)) (aref array (+ 8 (* tile 16) y))) 1) 28 | )))) 29 | finally (return output))) 30 | 31 | (defun linear-array (array) 32 | (coerce 33 | (make-array (array-total-size array) 34 | :element-type (array-element-type array) 35 | :displaced-to array) 36 | `(simple-array ,(array-element-type array) (*)))) 37 | 38 | (defun default-color-table () 39 | (skippy:make-color-table 40 | :initial-contents 41 | (mapcar (lambda (x) (apply #'skippy:rgb-color x)) 42 | '((0 0 0) 43 | (0 255 0) 44 | (255 0 0) 45 | (255 255 255))))) 46 | 47 | (defun write-gif (filename pixels) 48 | (let* ((width (array-dimension pixels 1)) 49 | (height (array-dimension pixels 0)) 50 | (data-stream (skippy:make-data-stream 51 | :width width 52 | :height height 53 | :color-table (default-color-table)))) 54 | (skippy:add-image 55 | (skippy:make-image :width width :height height 56 | :image-data (linear-array pixels)) 57 | data-stream) 58 | (skippy:output-data-stream data-stream filename))) 59 | 60 | (defun linear-to-matrix (linear width height) 61 | (let ((matrix (make-array (list height width) 62 | :element-type (array-element-type linear)))) 63 | (dotimes (y height matrix) 64 | (dotimes (x width) 65 | (setf (aref matrix y x) (aref linear (+ x (* y width)))))))) 66 | 67 | (defun read-gif (filename) 68 | (let* ((ds (skippy:load-data-stream filename)) 69 | (img (elt (skippy:images ds) 0))) 70 | (values 71 | (linear-to-matrix (skippy:image-data img) 72 | (skippy:width img) 73 | (skippy:height img)) 74 | (skippy:color-table ds)))) 75 | 76 | (defun encode-chr (pixels) 77 | (loop ;with sheet-width = (truncate (array-dimension pixels 1) 8) 78 | ;with sheet-height = (truncate (array-dimension pixels 0) 8) 79 | with output = (make-array ;;(* 16 sheet-width sheet-height) 80 | 0 81 | :element-type '(unsigned-byte 8) 82 | :fill-pointer t 83 | :adjustable t) 84 | for y from 0 below (array-dimension pixels 0) by 8 ;sheet-height 85 | do 86 | (loop for x from 0 below (array-dimension pixels 1) by 8;sheet-width 87 | do 88 | (dotimes (plane 2) 89 | (dotimes (oy 8) 90 | (vector-push-extend 91 | (loop for ox from 0 below 8 summing (ash (ldb (byte 1 plane) (aref pixels (+ y oy) (+ x (- 7 ox)))) ox)) 92 | output)))) 93 | finally (return output))) 94 | 95 | (defun encode-gif (pathname) 96 | "Helper function: Equivalent to (encode-chr (read-gif pathname))" 97 | (encode-chr (read-gif pathname))) 98 | -------------------------------------------------------------------------------- /nes.lisp: -------------------------------------------------------------------------------- 1 | (in-package :asm6502-nes) 2 | 3 | ;;;; ------------------------------------------------- 4 | ;;;; Definitions for programming the NES / Famicom 5 | ;;;; ------------------------------------------------- 6 | 7 | (defconstant +ntsc-clock-rate+ 1789772.5 8 | "CPU clock rate of an NTSC NES system. Derived from NTSC video clock.") 9 | 10 | ;;;; Hardware register addresses: 11 | 12 | (defconstant +ppu-cr1+ #x2000) 13 | (defconstant +ppu-cr2+ #x2001) 14 | (defconstant +ppu-status+ #x2002) 15 | (defconstant +spr-addr+ #x2003) 16 | (defconstant +spr-io+ #x2004) 17 | (defconstant +vram-scroll+ #x2005) 18 | (defconstant +vram-addr+ #x2006) 19 | (defconstant +vram-io+ #x2007) 20 | 21 | (defconstant +pulse1-control+ #x4000) 22 | (defconstant +pulse1-ramp+ #x4001) 23 | (defconstant +pulse1-fine+ #x4002) 24 | (defconstant +pulse1-coarse+ #x4003) 25 | (defconstant +pulse2-control+ #x4004) 26 | (defconstant +pulse2-ramp+ #x4005) 27 | (defconstant +pulse2-fine+ #x4006) 28 | (defconstant +pulse2-coarse+ #x4007) 29 | (defconstant +tri-cr1+ #x4008) 30 | (defconstant +tri-cr2+ #x4009) 31 | (defconstant +tri-freq1+ #x400A) 32 | (defconstant +tri-freq2+ #x400B) 33 | (defconstant +noise-control+ #x400C) 34 | (defconstant +noise-freq1+ #x400E) 35 | (defconstant +noise-freq2+ #x400F) 36 | (defconstant +dmc-control+ #x4010) 37 | (defconstant +dmc-dac+ #x4011) 38 | (defconstant +dmc-address+ #x4012) 39 | (defconstant +dmc-length+ #x4013) 40 | 41 | (defconstant +sprite-dma+ #x4014) 42 | (defconstant +papu-control+ #x4015) 43 | (defconstant +papu-irq-ctrl+ #x4017) 44 | 45 | (defconstant +joypad-1+ #x4016) 46 | (defconstant +joypad-2+ #x4017) 47 | 48 | ;;;; iNES File Output 49 | 50 | (defun ines-header (prg-pages chr-pages &key 51 | (mirror-mode :horizontal) 52 | (mapper 0) sram) 53 | "Generate an iNES header. PRG pages are 16 kilobyte. CHR pages are 8 kilobyte." 54 | (setf mirror-mode (case mirror-mode 55 | (:horizontal 0) 56 | (:vertical 1) 57 | (otherwise mirror-mode))) 58 | (let ((control-1 (logior mirror-mode 59 | (ash (logand mapper #x0F) 4) 60 | (if sram 2 0))) 61 | (control-2 (logand mapper #xF0))) 62 | (vector #x4E #x45 #x53 #x1A prg-pages chr-pages control-1 control-2 0 0 0 0 0 0 0 0))) 63 | 64 | (defun write-ines (filename prg &key 65 | (chr (make-array 8192 :initial-element 1)) 66 | (mirror-mode :horizontal) 67 | (mapper 0) 68 | (sram nil)) 69 | "Write a iNES (.nes) file." 70 | (assert (zerop (mod (length prg) #x4000))) 71 | (assert (zerop (mod (length chr) #x2000))) 72 | (setf (binary-file filename) 73 | (concatenate 'vector 74 | (ines-header (/ (length prg) #x4000) 75 | (/ (length chr) #x2000) 76 | :mirror-mode mirror-mode 77 | :mapper mapper 78 | :sram sram) 79 | prg 80 | chr)) 81 | (format *trace-output* "~&Created \"~A\"~%" filename) 82 | (values)) 83 | 84 | ;;;; NES Utilities 85 | 86 | (defun ppuaddr (address) 87 | (poke (msb address) +vram-addr+) 88 | (poke (lsb address) +vram-addr+)) 89 | 90 | (defun ppuxy (x y &optional (nametable #x2000)) 91 | (ppuaddr (+ nametable x (* y 32)))) 92 | 93 | ;;;; DAC stuff 94 | 95 | ;;; I'm sure these maps are way off. My methods are bogus, my results 96 | ;;; inconsistent. Regardless, I'm convinced there's a significant 97 | ;;; curve, correcting for which will greatly improve the quality of 98 | ;;; digital audio output. To be continued. 99 | 100 | (defparameter *dac-reverse-map* 101 | #(0 1 1 2 3 3 4 5 5 6 7 7 8 9 9 10 11 11 12 13 14 14 15 16 16 17 18 19 19 102 | 20 21 22 23 23 24 25 26 26 27 28 29 30 31 31 32 33 34 35 36 36 37 38 39 103 | 40 41 42 43 44 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 104 | 63 64 65 66 67 68 69 71 72 73 74 75 76 77 79 80 81 82 83 84 86 87 88 89 105 | 91 92 93 94 96 97 98 100 101 102 104 105 106 108 109 111 112 113 115 116 106 | 118 119 121 122 124 125 127) 107 | "Mapping to predistort compensating for DMC DAC nonlinearity") 108 | 109 | (defparameter *dac-value-map* 110 | #(0.0 1.5541384 1.5541384 3.0946667 4.621763 4.621763 6.1356025 7.636356 111 | 7.636356 9.124193 10.59928 10.59928 12.061781 13.511853 13.511853 112 | 14.949657 16.375347 16.375347 17.789076 19.190994 20.581245 20.581245 113 | 21.95998 23.327337 23.327337 24.683456 26.02848 27.362541 27.362541 114 | 28.68577 29.9983 31.300266 32.591785 32.591785 33.872993 35.144005 115 | 36.404945 36.404945 37.65593 38.897083 40.128517 41.35034 42.56267 116 | 42.56267 43.765617 44.959286 46.14379 47.31923 48.485706 48.485706 117 | 49.64333 50.792194 51.9324 53.064045 54.187225 55.302036 56.40857 118 | 57.506916 57.506916 58.59717 59.67942 60.753754 61.820248 62.879 119 | 63.93009 64.97361 66.00963 67.03822 68.05949 69.073494 70.08032 71.08003 120 | 72.072716 73.05845 74.0373 75.00932 75.97462 76.933235 77.885254 121 | 78.83074 79.76975 80.70237 81.62865 82.54866 84.3701 85.27167 86.16721 122 | 87.05679 87.940475 88.81831 89.69035 91.41732 92.27234 93.1218 93.96576 123 | 94.80425 95.637344 97.28754 98.10473 98.91673 99.72357 101.32201 124 | 102.1137 102.90043 103.68225 105.23135 105.9987 106.76134 108.27257 125 | 109.021255 109.765396 111.24015 111.97085 112.69715 114.136734 126 | 114.850075 116.2641 116.964836 117.661446 119.04242 119.72685 121.0838 127 | 121.75639 123.08993 123.75097 125.0617 125.71149 127.0) 128 | "Unquantized output values associated with each entry of the reverse map, for computing error.") 129 | 130 | (defun clamp (min max x) (max min (min max x))) 131 | 132 | (defun process-dac-waveform (vector &key 133 | (prescale 0.5) 134 | (white-noise-bits 0.0) 135 | (error-feedback 1.0)) 136 | (let ((x 0.0)) 137 | (map 'vector 138 | (lambda (y) 139 | (incf x (* prescale y)) 140 | (let ((idx (clamp 0 127 (round x)))) 141 | (prog1 (aref *dac-reverse-map* idx) 142 | (incf x (* white-noise-bits (- (random 2.0) 1.0))) 143 | (setf x (* error-feedback 144 | (- x (aref *dac-value-map* idx))))))) 145 | vector))) 146 | 147 | ;;;; NSF file format 148 | 149 | (defconstant +nsf-chip-vrc6+ 1) 150 | (defconstant +nsf-chip-vrc7+ 2) 151 | (defconstant +nsf-chip-fds+ 4) 152 | (defconstant +nsf-chip-mmc5+ 8) 153 | (defconstant +nsf-chip-namco106+ 16) 154 | (defconstant +nsf-chip-fme-07+ 32) 155 | 156 | (defun translate-nsf-chips (chip-list) 157 | (loop for chip in chip-list summing 158 | (etypecase chip 159 | ((unsigned-byte 8) chip) 160 | (symbol 161 | (ecase chip 162 | (:vrc6 +nsf-chip-vrc6+) 163 | (:vrc7 +nsf-chip-vrc7+) 164 | (:fds +nsf-chip-fds+) 165 | (:mmc5 +nsf-chip-mmc5+) 166 | (:namco106 +nsf-chip-namco106+) 167 | (:fme-07 +nsf-chip-fme-07+)))))) 168 | 169 | (defun emit-nsf-header (num-songs load-addr init-addr play-addr 170 | &key 171 | (song-name nil) 172 | (artist nil) 173 | (copyright-holder nil) 174 | (starting-song 1) 175 | (ntsc-speed 16639) 176 | (bankswitch-init #(0 0 0 0 0 0 0 0)) 177 | (mode :ntsc) 178 | (pal-speed 19997) 179 | (chips 0)) 180 | (assert (= 8 (length bankswitch-init))) 181 | (when (listp chips) 182 | (setf chips (translate-nsf-chips chips))) 183 | (setf mode (cond 184 | ((eql mode :ntsc) 0) 185 | ((eql mode :pal) 1) 186 | ((eql mode :dual) 2) 187 | ((typep mode '(unsigned-byte 8)) mode) 188 | (t (error "Mode must be a byte value, or one of :NTSC, :PAL, or :DUAL")))) 189 | (labels 190 | ((null-terminated (string32) 191 | (prog1 string32 (setf (aref string32 31) 0))) 192 | 193 | (string32 (string) 194 | (emit 195 | (null-terminated 196 | (map-into (make-array 32 :element-type '(unsigned-byte 8) 197 | :initial-element 0) 198 | 'char-code 199 | string)))) 200 | 201 | (labelify (x) (if (symbolp x) (label x) x))) 202 | (emit (map 'vector 'char-code "NESM")) 203 | (db #x1A) 204 | (db #x01) ; Version 205 | (db num-songs) 206 | (db starting-song) 207 | (dw (labelify load-addr)) 208 | (dw (labelify init-addr)) 209 | (dw (labelify play-addr)) 210 | (string32 (or song-name "")) 211 | (string32 (or artist "")) 212 | (string32 (or copyright-holder "")) 213 | (dw ntsc-speed) 214 | (emit bankswitch-init) 215 | (dw pal-speed) 216 | (db mode) 217 | (db chips) 218 | (db 0) ; Reserved bytes 219 | (db 0) 220 | (db 0) 221 | (db 0))) 222 | 223 | 224 | 225 | -------------------------------------------------------------------------------- /nesmus.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nesmus) 2 | 3 | ;;;; --- Music language --- 4 | 5 | (defun register (address value) (list value address)) 6 | (defun nop-write () (register #x0D 0)) ; Dummy write to unused sound register. 7 | 8 | (defun pad-list (list padding desired-length) 9 | (assert (<= (length list) desired-length)) 10 | (append list (loop repeat (- desired-length (length list)) collect padding))) 11 | 12 | (defun pad-frame (frame) 13 | (pad-list frame (nop-write) 16)) 14 | 15 | (defun segment (length list) ; rewrite as map-into? 16 | (if (< (length list) length) 17 | (pad-list list nil length) 18 | (subseq list 0 length))) 19 | 20 | (defun translate-freq (seqlen lbits freq) 21 | (let ((fbits (delay 'fbits (freq) 22 | (round (/ +ntsc-clock-rate+ seqlen freq))))) 23 | (values (delay 'reg2 (fbits) (ldb (byte 8 0) fbits)) 24 | (delay 'reg3 (fbits) (logior (ldb (byte 3 8) fbits) 25 | (ash lbits 3)))))) 26 | 27 | #+NIL 28 | (defun translate-freq (seqlen lbits freq) 29 | (let ((fbits (round (/ +ntsc-clock-rate+ seqlen freq)))) 30 | (values (ldb (byte 8 0) fbits) 31 | (logior (ldb (byte 3 8) fbits) 32 | (ash lbits 3))))) 33 | 34 | (defvar *channel-timer* (vector nil nil nil) 35 | "Last value written to channel timer counts. Used for vibrato effect.") 36 | 37 | (defun noteon (chan lbits freq) 38 | (multiple-value-bind (base seqlen) 39 | (ecase chan 40 | (0 (values 0 8)) 41 | (1 (values 4 8)) 42 | (2 (values 8 32))) 43 | (multiple-value-bind (v2 v3) (translate-freq seqlen lbits freq) 44 | (setf (aref *channel-timer* chan) (logior (ash (logand 7 v3) 8) v2)) 45 | (list 46 | (register (+ 2 base) v2) 47 | (register (+ 3 base) v3))))) 48 | 49 | (defun vibrato (channel length) 50 | (check-type channel (integer 0 2)) 51 | (when (null (aref *channel-timer* channel)) 52 | (error "Cannot use vibrato on channel ~A, last note frequency is unknown" channel)) 53 | (let* ((timer-count (aref *channel-timer* channel)) 54 | (lsb (logand timer-count #xFF)) 55 | (reg (+ 2 (* channel 4)))) 56 | (unless (<= 2 lsb 253) 57 | (warn "Vibrato will be detuned at this pitch...")) 58 | (segment length 59 | (repeat (* 8 (ceiling length 8)) 60 | (seq 61 | (list (list (register reg (clamp (+ lsb +1) 0 255)))) 62 | (list (list (register reg (clamp (+ lsb +2) 0 255)))) 63 | (list (list (register reg (clamp (+ lsb +1) 0 255)))) 64 | (list (list (register reg (clamp (+ lsb 0) 0 255)))) 65 | (list (list (register reg (clamp (+ lsb -1) 0 255)))) 66 | (list (list (register reg (clamp (+ lsb -2) 0 255)))) 67 | (list (list (register reg (clamp (+ lsb -1) 0 255)))) 68 | (list (list (register reg (clamp (+ lsb 0) 0 255))))))))) 69 | 70 | (defun translate-length (length) 71 | "Find closest match to load the length counter." 72 | (first 73 | (first 74 | (sort 75 | (copy-list 76 | '((0 #x0A) (1 #xFE) 77 | (2 #x14) (3 #x02) 78 | (4 #x28) (5 #x04) 79 | (6 #x50) (7 #x06) 80 | (8 #xA0) (9 #x08) 81 | (10 #x3C) (11 #x0A) 82 | (12 #x0E) (13 #x0C) 83 | (14 #x1A) (15 #x0E) 84 | (16 #x0C) (17 #x10) 85 | (18 #x18) (19 #x12) 86 | (20 #x30) (21 #x14) 87 | (22 #x60) (23 #x16) 88 | (24 #xC0) (25 #x18) 89 | (26 #x48) (27 #x1A) 90 | (28 #x10) (29 #x1C) 91 | (30 #x20) (31 #x1E))) 92 | #'< 93 | :key (lambda (p) (abs (- (second p) length))))))) 94 | 95 | (defun cfg (channel &key (duty 2) (vol 15) (env t) (loop nil)) 96 | (check-type duty (integer 0 3)) 97 | (list 98 | (list (register (* channel 4) 99 | (logior (ash duty 6) 100 | (if env 0 #x10) 101 | (if loop #x20 0) 102 | vol))))) 103 | 104 | (defun note (channel length freq &key (d length) cfg vibrato-delay) 105 | (check-type channel (integer 0 1)) 106 | (segment length 107 | (para 108 | (and cfg (apply 'cfg channel cfg)) 109 | (list 110 | (noteon channel (translate-length d) freq)) 111 | (and vibrato-delay 112 | (seq 113 | (rst vibrato-delay) 114 | (vibrato channel (- length vibrato-delay))))))) 115 | 116 | (defun silence-channel (channel) 117 | (ecase channel 118 | (0 (note 0 1 1 :d 0 :cfg '(:vol 0 :loop t :env nil))) 119 | (1 (note 1 1 1 :d 0 :cfg '(:vol 0 :loop t :env nil))))) 120 | 121 | (defun tri (length freq &key (d length) vibrato-delay) 122 | (para 123 | (cond 124 | ((<= d 31) 125 | (segment length 126 | (list 127 | (list* (register #x8 (* d 4)) 128 | (noteon 2 1 freq))))) 129 | (t 130 | (segment length 131 | (seq 132 | (list (list* (register #x8 #x8F) 133 | (noteon 2 1 freq))) 134 | (rst (if (= d length) 135 | (- length 2) 136 | (1- d))) 137 | (list (list (register #x8 0) (register #xB #x07))))))) 138 | (and vibrato-delay 139 | (seq 140 | (rst vibrato-delay) 141 | (segment (max 0 (- length vibrato-delay)) 142 | (vibrato 2 (- length vibrato-delay))))))) 143 | 144 | (defun noise (length duration period &key short loop (env t) (vol 15)) 145 | (check-type duration (integer 0 31)) 146 | (check-type vol (integer 0 15)) 147 | (check-type period (integer 0 15)) 148 | (segment length 149 | (list 150 | (list 151 | (register #xC (logior (if loop #x20 0) 152 | (if env 0 #x10) 153 | vol)) 154 | (register #xE (logior (if short #x80 0) 155 | period)) 156 | (register #xF (ash (translate-length duration) 3)))))) 157 | 158 | (defun para (&rest args) 159 | (apply #'mapcar #'append (mapcar (lambda (x) (pad-list x nil (reduce #'max args :key #'length))) args))) 160 | 161 | (defun measure (&rest args) 162 | (segment 128 (apply 'para args))) 163 | 164 | ;;; These look familiar: 165 | (defun seq (&rest args) 166 | (apply #'concatenate 'list args)) 167 | 168 | (defun repeat (n &rest args) 169 | (apply #'seq (mapcan #'copy-list (loop repeat n collect args)))) 170 | 171 | (defun rst (length) (segment length nil)) 172 | 173 | (defparameter *tuning-root* 276.0) 174 | 175 | (defun get-tuning-root () 176 | (make-promise :name "Tuning Root" 177 | :fun (lambda () 178 | ;;(when *tuning-root* (print (list :tuning-root *tuning-root*))) 179 | (or *tuning-root* 180 | (error 'asm6502::resolvable-condition 181 | :path "Tuning root not set."))))) 182 | 183 | (defun et (&rest args) 184 | (assert (not (null args))) 185 | (delay 'et ((tuning (get-tuning-root))) 186 | (* tuning (expt 2 (/ (apply '+ args) 12))))) 187 | 188 | (defun kick (length) 189 | (noise length 8 15 :vol 1)) 190 | 191 | (defun snare (length &optional (variation 0)) 192 | (noise length 8 (+ 10 variation) :vol 1)) 193 | 194 | (defun hat (length &optional (variation 0)) 195 | (noise length 4 (+ variation 1) :vol 1)) 196 | 197 | (defun thump (length &optional (pitch (et -24))) 198 | (segment 199 | length 200 | (seq (tri 1 (delay nil (pitch) (* pitch 1))) 201 | (tri 1 (delay nil (pitch) (* pitch 4/3))) 202 | (tri 1 (delay nil (pitch) (* pitch 2/3))) 203 | (tri 1 (delay nil (pitch) (* pitch 1/2)))))) 204 | 205 | (defun shaker (length volume) 206 | (assert (>= length 2)) 207 | (segment 208 | length 209 | (seq 210 | (noise 1 1 1 :env nil :loop t :vol volume) 211 | (noise 1 1 1 :env nil :vol 0)))) 212 | 213 | (defun eltmod (i seq) (elt seq (mod i (length seq)))) 214 | (defun clamp (x min max) (max (min x max) min)) 215 | 216 | (defun volramp (&optional (start 15) (rate -1/10)) 217 | (lambda (time) 218 | (clamp (round (+ start (* time rate))) 219 | 0 220 | 15))) 221 | 222 | (defun shimmer (&optional (time-shift -4) (phase-offset 0)) 223 | (lambda (time) (mod (+ phase-offset (ash time time-shift)) 4))) 224 | 225 | (defun arpeggio (channel length chord &key 226 | (rate 3) 227 | (d rate) 228 | (env nil) 229 | (loop t) 230 | (mute nil) 231 | (volume (volramp)) 232 | (duty (shimmer))) 233 | (assert (not (null chord))) 234 | (seq 235 | (segment (if mute (1- length) length) 236 | (loop for time below length by rate 237 | for index upfrom 0 238 | append (note channel rate (eltmod index chord) 239 | :d d 240 | :cfg (list :duty (funcall duty time) 241 | :vol (funcall volume time) 242 | :env env 243 | :loop loop)))) 244 | (and mute (silence-channel channel)))) 245 | 246 | (defun fat-arp (length chord &rest args) 247 | (para 248 | (apply #'arpeggio 0 length (apply #'chord (- (first chord) 0.06) (rest chord)) 249 | :duty (shimmer -2) args) 250 | (apply #'arpeggio 1 length (apply #'chord (+ (first chord) 0.06) (rest chord)) 251 | :duty (shimmer -2 2) args))) 252 | 253 | (defun funky-arp (&rest args) 254 | (fat-arp (* 8 (length args)) (list* 0.0 args) 255 | :d 15 :rate 8 :env t :loop nil :volume (constantly 1) :mute t)) 256 | 257 | (defun chord (root &rest notes) 258 | (mapcar (lambda (note) (et root note)) notes)) 259 | 260 | ;;;; Song authoring framework 261 | 262 | (defun write-song-data-for-reg-player (song-frames start-label end-label) 263 | (let ((write-patterns (make-hash-table :test 'equal)) 264 | (histogram (make-array 16)) 265 | (music-sequence nil) 266 | (start-address *origin*)) 267 | (align 16) 268 | (map nil (lambda (frame) 269 | (unless (<= (length frame) 16) 270 | (error "Too many writes! ~X" (mapcar 'second frame))) 271 | (incf (aref histogram (length frame))) 272 | (setf frame (pad-frame frame)) 273 | (unless (gethash frame write-patterns) 274 | (setf (gethash frame write-patterns) *origin*) 275 | ;; Reverse order, because player scans backward! 276 | (dolist (pair (reverse frame)) (apply 'db pair))) 277 | (push (gethash frame write-patterns) music-sequence)) 278 | song-frames) 279 | (setf music-sequence (nreverse music-sequence)) 280 | (align 2) 281 | (set-label start-label) 282 | (map nil #'dw music-sequence) 283 | (set-label end-label) 284 | (print (list :pattern-count (hash-table-count write-patterns) 285 | :frame-count (length music-sequence) 286 | :write-count-histogram histogram 287 | :start-address start-address 288 | :seq-start (label start-label) 289 | :seq-end (label end-label) 290 | ;;:sequence music-sequence 291 | :total-size (- *origin* start-address))))) 292 | 293 | (defvar *last-audition-function* nil) 294 | 295 | ;;; TODO: Implement more memory-efficient encoding.. 296 | 297 | (defparameter *defpattern-bindings* 298 | (list 299 | (list '*channel-timer* (lambda () (vector nil nil nil))))) 300 | 301 | (defmacro define-song (name (&key use-packages artist (copyright-holder artist))) 302 | (unless (stringp name) 303 | (error "Song name must be a string")) 304 | (let* ((package-name (format nil "~A (song)" name)) 305 | (package (or (find-package package-name) 306 | (make-package package-name))) 307 | (asm-fn-name (intern "ASSEMBLE-IN-CONTEXT" package))) 308 | `(eval-when (:compile-toplevel :load-toplevel :execute) 309 | (defpackage ,package-name 310 | (:use :common-lisp 311 | #|:6502 :asm6502 :asm6502-utility :asm6502-nes|# 312 | :nesmus 313 | ,@use-packages)) 314 | (in-package ,package-name) 315 | (defparameter ,(intern "*SONG-NAME*" package) ,name) 316 | (defparameter ,(intern "*ARTIST*" package) ,artist) 317 | (defparameter ,(intern "*COPYRIGHT-HOLDER*" package) ,copyright-holder) 318 | (defmacro ,(intern "DEFPATTERN" package) (name (&key parameters audition accompany) &body body) 319 | `(progn 320 | ;; Tempted to transform the name so it can't collide with 321 | ;; CL package.. 322 | (defun ,name ,parameters 323 | (print (list :defining ',name)) 324 | (progv 325 | (mapcar 'first *defpattern-bindings*) 326 | (mapcar (lambda (spec) (funcall (second spec))) 327 | *defpattern-bindings*) 328 | (seq ,@body))) 329 | (setf (get ',name 'audition) 330 | (lambda (loop-count) 331 | (print (list :previewing ',name)) 332 | (generate-nsf-preview 333 | ',name 334 | (lambda () 335 | (repeat loop-count 336 | (para 337 | ,@accompany 338 | (,name ,@audition)))) 339 | :break-at-end t)) 340 | *last-audition-function* 341 | (prog1 (get ',name 'audition) 342 | (print "Set last audition function."))))) 343 | (defun ,(intern "NSF-OUTPUT-FILE" package) (filename) 344 | (generate-nsf-preview ,name #',asm-fn-name :filename filename))))) 345 | 346 | (defun emit-fixed-cycle-player (context var-base &key break-at-end) 347 | "Emit fixed-cycle player routine. Requires VAR-BASE specifies 8 bytes of adjacent zeropage storage." 348 | (check-type var-base (integer 0 250)) 349 | (let* ((*context* context) 350 | ;; Music player vars 351 | (mfr-addr (+ var-base 0)) ; Frame working pointer (temporary) 352 | (mfr-get (indi mfr-addr)) 353 | (mptr (+ var-base 2)) ; Playback pointer 354 | (mptr-msb (zp (1+ mptr))) 355 | (mptr-lsb (zp mptr)) 356 | (endptr (+ var-base 4)) 357 | (startptr (+ var-base 6))) 358 | 359 | (procedure player-load 360 | (pla) 361 | (clc) 362 | (adc (imm 1)) 363 | (sta (zp mfr-addr)) 364 | (pla) ; Stash return address in MFR 365 | (adc (imm 0)) 366 | (sta (zp (1+ mfr-addr))) 367 | (pla) 368 | (sta mptr-lsb) 369 | (sta (zp startptr)) 370 | (pla) 371 | (sta mptr-msb) 372 | (sta (zp (1+ startptr))) 373 | (pla) 374 | (sta (zp endptr)) 375 | (pla) 376 | (sta (zp (1+ endptr))) 377 | (jmp (indirect mfr-addr))) 378 | 379 | (procedure play-frame 380 | (cld) 381 | 382 | ;; Transfer *MPTR to MFR and play this frame. 383 | (ldy (imm 0)) ; LSB of new music frame pointer 384 | (lda (indi mptr)) 385 | (sta (zp mfr-addr)) 386 | (iny) ; MSB of new music frame pointer 387 | (lda (indi mptr)) 388 | (sta (zp (1+ mfr-addr))) 389 | (jsr 'player-write) ; Play frame from MFR. 390 | 391 | ;; Advance music pointer 392 | (clc) 393 | (inc mptr-lsb) ; Requires music is word aligned 394 | (inc mptr-lsb) 395 | (asif :zero 396 | (inc mptr-msb)) 397 | 398 | (lda mptr-lsb) 399 | (cmp (zp endptr)) 400 | (asif :equal 401 | (lda mptr-msb) 402 | (cmp (zp (1+ endptr))) 403 | (asif :equal 404 | (when break-at-end 405 | (brk) 406 | (db #xF1) 407 | (rts)) 408 | (pokeword (wordvar startptr) (wordvar mptr)))) 409 | 410 | (rts)) 411 | 412 | ;;; Do register writes for this frame of music. Set MFR to the 413 | ;;; set of writes for this frame (16*2 bytes). 414 | (procedure player-write 415 | (ldy (imm #x1F)) 416 | (as/until :negative 417 | (lda mfr-get) 418 | (tax) 419 | (dey) 420 | (lda mfr-get) 421 | (sta (abx #x4000)) 422 | (dey)) 423 | (rts)))) 424 | 425 | (defun generate-nsf-preview (name continuation &key filename (break-at-end nil)) 426 | (setf filename (or filename (format nil "/tmp/nsf-audition/~A.nsf" name))) 427 | (let ((*context* (make-instance 'basic-context))) 428 | 429 | (emit-nsf-header 1 #x8000 'init 'play-frame 430 | :song-name (format nil "~A" name)) 431 | 432 | (setf *origin* #x8000) 433 | 434 | (emit-fixed-cycle-player *context* #x80 :break-at-end break-at-end) 435 | 436 | (procedure init 437 | (cld) 438 | ;;(pokeword (label :seq-start) mptr) 439 | (pushword (label :seq-end)) 440 | (pushword (label :seq-start)) 441 | (jsr 'player-load) 442 | (rts)) 443 | 444 | (write-song-data-for-reg-player (funcall continuation) :seq-start :seq-end) 445 | 446 | (ensure-directories-exist filename) 447 | (setf (binary-file filename) (link *context*)) 448 | (format t "~&Wrote output to ~A~%" filename)) 449 | filename) 450 | 451 | (defun play-audition (loop-count player-cmd) 452 | (when *last-audition-function* 453 | (uiop:run-program 454 | (list player-cmd (funcall *last-audition-function* loop-count)) 455 | :output :interactive 456 | :ignore-error-status t))) 457 | -------------------------------------------------------------------------------- /nesmusic.el: -------------------------------------------------------------------------------- 1 | ;; -*- coding: utf-8; lexical-binding: t -*- 2 | 3 | ;;;; Emacs minor-mode for composing NES music 4 | 5 | (require 'cl) 6 | 7 | (define-minor-mode nesmusic-mode 8 | "\\\ 9 | Compose music for the Nintendo Entertainment System 10 | 11 | \\[nesmusic-audition] - Audition pattern" 12 | nil 13 | " NESmusic" 14 | '(("\C-c\C-a" . nesmusic-audition))) 15 | 16 | (defun nesmusic-slime-search-buffer-package () 17 | (interactive) 18 | (let ((case-fold-search t) 19 | (regexp "^(\\(cl:\\|nesmus:\\)?define-song\\>[ ']*\"\\([[:alnum:]\|[:upper:]\|[:space:]]*\\)")) 20 | (save-excursion 21 | (if (or (re-search-backward regexp nil t) 22 | (re-search-forward regexp nil t)) 23 | (format "%s (song)" (match-string-no-properties 2)) 24 | (slime-search-buffer-package))))) 25 | 26 | (setq slime-find-buffer-package-function 27 | 'nesmusic-slime-search-buffer-package) 28 | 29 | (defcustom nesmusic-player-path nil 30 | "Path to NSF player" 31 | :type 'string 32 | :group 'nesmusic) 33 | 34 | (defun nesmusic-ensure-player-path-set () 35 | (interactive) 36 | (unless nesmusic-player-path 37 | (setq nesmusic-player-path 38 | (expand-file-name (read-file-name "NSF Player: " nil nil t "festalon" 'file-executable-p))))) 39 | 40 | ;; (message "Directory %s" (slime-eval `(swank:default-directory))) 41 | 42 | (defun nesmusic-audition (&optional repeat-count) 43 | (interactive "P") 44 | (nesmusic-ensure-player-path-set) 45 | (unless (and (integerp repeat-count) (> repeat-count 0)) 46 | (setq repeat-count 1)) 47 | (message "%s" repeat-count) 48 | 49 | (slime-connection) 50 | (let* ((region (slime-region-for-defun-at-point)) 51 | (start-offset (first region)) 52 | (string (apply 'buffer-substring-no-properties region))) 53 | (slime-flash-region (first region) (second region)) 54 | (apply 'run-hook-with-args 'slime-before-compile-functions region) 55 | 56 | (let* ((line (save-excursion 57 | (goto-char start-offset) 58 | (list (line-number-at-pos) (1+ (current-column))))) 59 | (position `((:position ,start-offset) (:line ,@line)))) 60 | (slime-eval-async 61 | `(swank:compile-string-for-emacs 62 | ,string 63 | ,(buffer-name) 64 | ',position 65 | ,(if (buffer-file-name) (slime-to-lisp-filename (buffer-file-name))) 66 | ',slime-compilation-policy) 67 | (lambda (result) 68 | (hacked-slime-compilation-finished result repeat-count)))))) 69 | 70 | (defun hacked-slime-compilation-finished (result repeat-count) 71 | (with-struct (slime-compilation-result. notes duration successp 72 | loadp faslfile) result 73 | (setf slime-last-compilation-result result) 74 | (slime-show-note-counts notes duration (cond ((not loadp) successp) 75 | (t (and faslfile successp)))) 76 | (when slime-highlight-compiler-notes 77 | (slime-highlight-notes notes)) 78 | (run-hook-with-args 'slime-compilation-finished-hook notes) 79 | (cond 80 | ((and loadp faslfile 81 | (or successp 82 | (slime-load-failed-fasl-p))) 83 | (slime-eval-async `(swank:load-file ,faslfile) 84 | (lambda (_) 85 | (nesmusic-audition-last-pattern repeat-count)))) 86 | (successp 87 | (nesmusic-audition-last-pattern repeat-count))))) 88 | 89 | (defun nesmusic-audition-last-pattern (repeat-count) 90 | (slime-eval-async `(nesmus::play-audition 91 | ,repeat-count 92 | ,nesmusic-player-path))) 93 | 94 | (provide 'nesmusic) 95 | -------------------------------------------------------------------------------- /nestunes/sound-tests.lisp: -------------------------------------------------------------------------------- 1 | (nesmus:define-song "Audio Tests" ()) 2 | 3 | (defpattern vibrato-test () 4 | (para 5 | (print (note 0 96 (et 0) :cfg '(:env nil :duty 2))) 6 | (seq 7 | (rst 24) 8 | (repeat 6 9 | (list (list (register 2 #x2b))) 10 | (list (list (register 2 #x2c))) 11 | (list (list (register 2 #x2d))) 12 | (list (list (register 2 #x2c))) 13 | (list (list (register 2 #x2b))) 14 | (list (list (register 2 #x2a))) 15 | (list (list (register 2 #x29))) 16 | (list (list (register 2 #x2a))))))) 17 | 18 | (defpattern sweep-vibrato-test () 19 | (para 20 | (print (note 0 128 (et 0) :cfg '(:env nil :duty 2))) 21 | (list (list (register 1 0))) 22 | (seq 23 | (rst 24) 24 | (repeat 8 25 | (list (list (register 1 #xDF))) 26 | (rst 2) 27 | (list (list (register 1 #xD7))) 28 | (rst 2))))) 29 | 30 | (defpattern triangle-vibrato-test () 31 | (para 32 | ;;(print (tri 31 (et 0))) 33 | (list (list (register 8 #x8C) (register 10 #xCB) (register #xB 8))) 34 | (seq 35 | (rst 24) 36 | (repeat 37 | 6 38 | (list (list (register 10 #xCB))) 39 | (list (list (register 10 #xCA))) 40 | (list (list (register 10 #xC9))) 41 | (list (list (register 10 #xCA))) 42 | (list (list (register 10 #xCB))) 43 | (list (list (register 10 #xCC))) 44 | (list (list (register 10 #xCD))) 45 | (list (list (register 10 #xCC))))))) 46 | 47 | ;;; Test new vibrato feature of TRI function 48 | (defpattern triangle-vibrato-1 () 49 | (apply 'seq 50 | (tri 128 (et -24) :vibrato-delay 24) 51 | (tri 128 (et -12) :vibrato-delay 24) 52 | (tri 128 (et 0) :vibrato-delay 24) 53 | (tri 128 (et 12) :vibrato-delay 24) 54 | (tri 128 (et 24) :vibrato-delay 24) 55 | (loop for pitch from -24 upto 24 56 | collect (tri 32 (et pitch) :vibrato-delay 0)))) 57 | 58 | (defpattern pulse-vibrato-1 () 59 | (apply 'seq 60 | (cfg 0 :env nil :loop t) 61 | (note 0 96 (et 0) :vibrato-delay 24) 62 | (note 0 96 (et 12) :vibrato-delay 24) 63 | (note 0 96 (et 24) :vibrato-delay 24) 64 | (note 0 96 (et 36) :vibrato-delay 24) 65 | (note 0 96 (et 48) :vibrato-delay 24) 66 | (loop for pitch from -4 upto 48 67 | collect (note 0 32 (et pitch) :vibrato-delay 0)))) 68 | -------------------------------------------------------------------------------- /nestunes/steps.lisp: -------------------------------------------------------------------------------- 1 | (nesmus:define-song "Steps" ()) 2 | 3 | (defpattern bassline-1A () 4 | (tri 24 (et -1) :d 24 :vibrato-delay 12) 5 | (tri 24 (et -3) :d 24) 6 | 7 | (tri 24 (et -5) :d 24 :vibrato-delay 8) 8 | (tri 18 (et -7) :d 16) 9 | (tri 18 (et -9) :d 17) 10 | (tri 12 (et -10) :d 10) 11 | (tri 12 (et -12) :d 10) 12 | (tri 12 (et -14) :d 10) 13 | 14 | (tri 12 (et -3) :d 12) 15 | (tri 12 (et -5) :d 10) 16 | (tri 12 (et -6) :d 10) 17 | (tri 12 (et -3) :d 10)) 18 | 19 | (defpattern bassline-1B () 20 | (tri 24 (et -5) :d 24 :vibrato-delay 12) 21 | (tri 24 (et -7) :d 23) 22 | 23 | (tri 24 (et -9) :d 23 :vibrato-delay 8) 24 | (tri 18 (et -11) :d 16) 25 | (tri 18 (et -13) :d 15) 26 | (tri 12 (et -6) :d 10) 27 | (tri 12 (et -2) :d 10) 28 | (tri 12 (et -6) :d 10) 29 | 30 | (tri 12 (et -7) :d 12) 31 | (tri 12 (et -5) :d 10) 32 | (tri 12 (et -4) :d 10) 33 | (tri 12 (et -2) :d 12 :vibrato-delay 0)) 34 | 35 | (defpattern bassline-1C () 36 | (apply 37 | 'seq 38 | (mapcar 39 | (lambda (pitch duration) (tri 12 (et pitch) :d duration)) 40 | '(-9 -2 -5 -9 41 | -3 -10 -8 -7 42 | -5 -3 -1 -5 43 | -8 -11 -6 -14) 44 | '(9 8 8 10 9 8 8 10 9 8 8 10 9 8 8 12)))) 45 | 46 | (defpattern bassline-1D () 47 | (apply 48 | 'seq 49 | (mapcar 50 | (lambda (pitch duration) (tri 12 (et pitch) :d duration)) 51 | '(-13 -6 -1 -6 52 | -7 -5 -3 -2 53 | -9 -2 -5 -8 54 | -11 -8 -6 -14) 55 | '(8 8 8 11 8 8 8 9 8 8 8 11 9 9 11 9)))) 56 | 57 | (defpattern bassline-seq-1 () 58 | (bassline-1A) 59 | (bassline-1B) 60 | (bassline-1C) 61 | (bassline-1D)) 62 | 63 | (defparameter *sax-config* '(:env nil :loop nil :duty 1 :vol 7)) 64 | (defparameter *sax-long* '(:env nil :loop t :duty 1 :vol 7)) 65 | 66 | (defun bup (note length &key (d (1- length)) vibrato-delay) 67 | (para 68 | ;;(note 1 length (et note) :d d :cfg '(:env nil :loop nil :duty 0 :vol 6)) 69 | (note 0 length (* (et (+ note -1.6 ))) :d d :cfg *sax-config* :vibrato-delay vibrato-delay) 70 | (seq (list (list (register 1 #x8F)) 71 | nil 72 | nil 73 | nil 74 | nil 75 | (list (register 1 0)))))) 76 | 77 | (defpattern sax-1A (:accompany ((bassline-1A))) 78 | (bup 18 24 :vibrato-delay 16) 79 | (note 0 24 (et 14) :vibrato-delay 0) 80 | (bup 11 24) 81 | (note 0 18 (et 7)) 82 | (note 0 (+ 48 6) (et 10) :d 48 :vibrato-delay 12) 83 | (bup 11 18) 84 | (note 0 (+ 6 24) (et 9) :vibrato-delay 8)) 85 | 86 | (defpattern sax-1BCD (:accompany ((seq (bassline-1B) 87 | (bassline-1C) 88 | (bassline-1D)))) 89 | (bup 14 24) 90 | (note 0 24 (et 11) :vibrato-delay 8) 91 | (bup 7 24 :vibrato-delay 16) 92 | (note 0 18 (et 3)) 93 | (note 0 (+ 48 6) (et 6) :d 48 :vibrato-delay 20) 94 | (bup 7 24) 95 | (note 0 18 (et 5) :vibrato-delay 0) 96 | (note 0 (+ 48 6) (et 10) :vibrato-delay 24) 97 | (note 0 24 (et 11) :d 30 :vibrato-delay 8) 98 | (note 0 18 (et 9) :d 23) 99 | (note 0 (+ 6 48) (et 14) :vibrato-delay 8) 100 | 101 | (bup 15 24) 102 | (note 0 18 (et 15) :d 20) 103 | (note 0 (+ 6 48) (et 18) :d 64 :vibrato-delay 24) 104 | (note 0 24 (et 19) :vibrato-delay 8) 105 | (note 0 18 (et 19) :d 20) 106 | (note 0 (+ 6 48) (et 22) :d 64 :vibrato-delay 24) 107 | 108 | (note 0 18 (et 18) :vibrato-delay 0) 109 | (note 0 9 (et 18) :vibrato-delay 0) 110 | (rst 18)) 111 | 112 | ;; FIXME: redefines existing definition, breaks other hacks.. 113 | (defun chord (length volume decay mute &rest notes) 114 | (arpeggio 1 length (mapcar (lambda (x) (et (+ x 12))) notes) 115 | :rate (if (<= (length notes) 3) 2 1) 116 | :duty (constantly 2) 117 | :volume (volramp volume decay) 118 | :mute mute)) 119 | 120 | (defpattern chords-1A (:accompany ((bassline-1A) (sax-1A))) 121 | (segment (* 48 4) 122 | (seq 123 | (chord 24 7 -0.2 nil 10 6 3 -1 -6 -13) 124 | (chord 24 6 -0.2 nil 7 2 0 -3 -7 -15) 125 | (chord 24 7 -0.2 nil 9 6 2 -1 -10 -17) 126 | (chord 18 6 -0.3 nil 7 2 0 -4 -14 -19) 127 | (chord (+ 48 6) 7 -0.2 nil 7 5 2 -2 -13) 128 | (chord 18 6 -0.3 nil 4 0 -5 -8 -15) 129 | (chord 18 7 -0.3 t 6 2 -3 -10)))) 130 | 131 | (defpattern chords-1BCD (:accompany ((seq (bassline-1B) 132 | (bassline-1C) 133 | (bassline-1D)) 134 | (sax-1BCD))) 135 | (chord 24 7 -0.2 nil 9 6 2 -3 -8 -17) 136 | (chord 24 6 -0.2 nil 7 2 0 -4 -10 -19) 137 | (chord 24 7 -0.2 nil 2 -2 -5 -14 -21) 138 | (chord 18 6 -0.3 nil 6 3 -2 -13 -23) 139 | (chord 54 7 -0.2 nil 10 6 3 -1 -18 -25) 140 | (chord 24 6 -0.2 nil 5 3 0 -4 -7) 141 | (chord 18 6 -0.3 nil 10 2 0 -7 -14) 142 | (chord 54 6 -0.2 nil 7 2 -2 -14 -21) 143 | 144 | (chord 24 7 -0.2 nil 4 0 -3 -8) 145 | (chord 18 6 -0.3 nil 14 10 5 0 -6 -10) 146 | (chord 54 7 -0.2 nil 9 6 2 -1 -8 -13) 147 | 148 | (chord 24 7 -0.2 nil 8 4 1 -1 -10 -11) 149 | (chord 18 6 -0.3 nil 6 4 1 -6 -14) 150 | (chord 54 7 -0.2 nil 13 10 6 3 -8 -13) 151 | 152 | (chord 24 7 -0.2 nil 12 8 5 3 -7) 153 | (chord 18 6 -0.3 nil 10 8 2 -4 -14) 154 | (chord 54 7 -0.2 nil 14 10 5 0 -5 -9) 155 | 156 | (chord 18 6 -0.3 nil 11 8 3 1 -11) 157 | (chord 18 7 -0.3 t 10 6 4 1 -6) 158 | (rst 12)) 159 | 160 | (defpattern section-1 () 161 | (para (bassline-1A) 162 | (sax-1A) 163 | (chords-1A)) 164 | (para (sax-1BCD) 165 | (seq (bassline-1B) 166 | (bassline-1C) 167 | (bassline-1D)) 168 | (chords-1BCD))) 169 | 170 | ;;; ------------------------------------------------------------ 171 | 172 | ;; TODO: Fix note durations here 173 | (defpattern bassline-2A () 174 | (tri 24 (et -1) :d 23 :vibrato-delay 12) 175 | (tri 24 (et -3) :d 22) 176 | (tri 24 (et -5) :d 22 :vibrato-delay 6) 177 | (tri 18 (et -7) :d 16) 178 | (tri 18 (et -14) :d 16 :vibrato-delay 12) 179 | (tri 12 (et -9) :d 9) 180 | (tri 12 (et -5) :d 9) 181 | (tri 12 (et -2) :d 9) 182 | (tri 12 (et -3) :d 9) 183 | (tri 12 (et -5) :d 9) 184 | (tri 12 (et -6) :d 9) 185 | (tri 12 (et -8) :d 11 :vibrato-delay 4)) 186 | 187 | (defpattern bassline-2B () 188 | (tri 24 (et -5) :d 23 :vibrato-delay 12) 189 | (tri 24 (et -7) :d 22) 190 | (tri 24 (et -9) :d 20 :vibrato-delay 6) 191 | (tri 18 (et -11) :d 17) 192 | (tri 18 (et -13) :d 16 :vibrato-delay 12) 193 | (tri 12 (et -6) :d 9) 194 | (tri 12 (et -2) :d 9) 195 | (tri 12 (et -1) :d 9) 196 | (tri 12 (et -7) :d 9) 197 | (tri 12 (et -5) :d 9) 198 | (tri 12 (et -4) :d 9) 199 | (tri 12 (et -2) :d 11)) 200 | 201 | (defpattern bassline-2CD () 202 | (apply 'seq 203 | (mapcar (lambda (pitch-or-whatevs) 204 | (etypecase pitch-or-whatevs 205 | (integer (tri 12 (et pitch-or-whatevs) :d 8)) 206 | (list (apply 'tri 12 (et (first pitch-or-whatevs)) (rest pitch-or-whatevs))))) 207 | 208 | '(-9 -2 -5 (-8 :d 10) 209 | -3 (-3 :vibrato-delay 0) -10 (-10 :vibrato-delay 0) 210 | -5 -3 -1 -5 211 | (-8 :d 10 :vibrato-delay 0) -11 (-6 :d 12 :vibrato-delay 0) -14 212 | 213 | -13 -6 -3 (-1 :d 10 :vibrato-delay 4) 214 | (-7 :d 10) -5 (-4 :d 10) -2 215 | -9 -10 (-12 :vibrato-delay 4) -14 216 | (-11 :d 10) -8 (-6 :d 10 :vibrato-delay 4) -14)))) 217 | 218 | (defpattern sax-2A (:accompany ((bassline-2A))) 219 | (bup 18 24) 220 | (note 0 24 (et 14) :vibrato-delay 10) 221 | (note 0 24 (et 11) :vibrato-delay 10) 222 | (note 0 18 (et 7)) 223 | (note 0 54 (et 10) :vibrato-delay 20) 224 | (bup 11 18) 225 | (note 0 30 (et 9) :d 27 :vibrato-delay 8)) 226 | 227 | (defpattern sax-2B (:accompany ((bassline-2B))) 228 | (note 0 24 (et 14) :vibrato-delay 10 :d 21 :cfg *sax-config*) 229 | (note 0 24 (et 11) :vibrato-delay 10 :d 21) 230 | (bup 7 24) 231 | (note 0 18 (et 3)) 232 | (note 0 54 (et 6) :vibrato-delay 24 :d 48)) 233 | 234 | (defpattern sax-2C () 235 | (bup 7 24) 236 | (note 0 18 (et 5) :d 20) 237 | (note 0 54 (et 10) :d 48 :vibrato-delay 18) 238 | (bup 11 24) 239 | (note 0 18 (et 9) :d 15) 240 | (note 0 54 (et 14) :d 48 :vibrato-delay 10) 241 | (note 0 24 (et 15) :d 17) 242 | (note 0 18 (et 15) :d 17 :vibrato-delay 0) 243 | (note 0 54 (et 18) :d 47 :vibrato-delay 18) 244 | (note 0 24 (et 19) :d 18 :vibrato-delay 6) 245 | (note 0 18 (et 19) :d 16 :vibrato-delay 10) 246 | (note 0 54 (et 22) :d 48 :vibrato-delay 16)) 247 | 248 | (defpattern sax-2D () 249 | (note 0 6 (et 13) :cfg *sax-config*) 250 | (note 0 6 (et 16)) 251 | (note 0 6 (et 20)) 252 | (note 0 6 (et 23)) 253 | (note 0 18 (et 22) :vibrato-delay 5) 254 | (note 0 6 (et 19))) 255 | 256 | (defpattern chords-2A (#|:accompany ((bassline-2A) (sax-2A))|#) 257 | (chord 24 7 -0.2 nil 13 -13) 258 | (chord 24 6 -0.2 nil 11 6 5 0 -6 -15) 259 | (chord 24 7 -0.2 nil 9 6 2 -1 -10 -17) 260 | (chord 18 6 -0.3 nil 7 2 0 -4 -14 -19) 261 | (chord 54 7 -0.2 nil 2 -2 -5 -13 -21) 262 | (chord 18 6 -0.3 nil 4 0 -5 -8 -15) 263 | (chord 30 7 -0.3 t 14 10 5 0 -6 -10)) 264 | 265 | (defpattern chords-2B () 266 | (chord 24 7 -0.2 nil 9 6 2 -1 -8 -17) 267 | (chord 24 6 -0.2 nil 7 2 0 -3 -10 -19) 268 | (chord 24 7 -0.2 nil 2 -2 -5 -14 -21) 269 | (chord 18 6 -0.3 nil 6 3 -2 -13 -23) 270 | (chord 54 7 -0.2 nil 10 6 3 -3 -18 -25)) 271 | 272 | (defpattern chords-2C () 273 | (rst 24) 274 | (chord 18 7 -0.2 nil 7 2 0 -2 -10 -16) 275 | (chord 54 7 -0.2 nil 2 -2 -5 -14 -21) 276 | (chord 24 7 -0.2 nil 4 0 -3 -8) 277 | (chord 18 6 -0.2 nil 14 10 5 0 -6 -10) 278 | (chord 54 7 -0.2 nil 9 6 2 -1 -8 -13)) 279 | 280 | (defpattern chords-2D () 281 | (chord 24 7 -0.2 nil 8 4 1 -1 -8 -11) 282 | (chord 18 6 -0.2 nil 6 4 1 -6 -14) 283 | (chord 54 7 -0.2 nil 13 10 5 3 -6 -13) 284 | (chord 24 7 -0.2 nil 12 8 5 3 -7) 285 | (chord 18 6 -0.3 nil 10 8 2 -4 -14) 286 | (chord 54 7 -0.2 nil 14 10 5 0 -5 -9) 287 | (chord 24 7 -0.2 nil 11 8 4 -1 -11) 288 | (chord 12 8 -0.3 t 13 10 6 4 -10 -6) 289 | (rst 12)) 290 | 291 | (defpattern section-2 () 292 | (para 293 | (seq (bassline-2A) 294 | (bassline-2B) 295 | (bassline-2CD)) 296 | (seq (sax-2A) 297 | (sax-2B) 298 | (sax-2C) 299 | (sax-2D)) 300 | (seq (chords-2A) 301 | (chords-2B) 302 | (chords-2C) 303 | (chords-2D)))) 304 | 305 | ;;; ------------------------------------------------------------ 306 | 307 | (defun walking-bassline (notes &key (note-length 12)) 308 | (assert (not (zerop note-length))) 309 | (apply 310 | 'seq 311 | (mapcar (lambda (x) 312 | (etypecase x 313 | (integer (tri note-length (et x) :d (max 1 (round (* 0.7 note-length))))) 314 | (list (walking-bassline x :note-length (ash note-length -1))))) 315 | notes))) 316 | 317 | (defpattern bassline-3A () 318 | (walking-bassline 319 | '(-13 -1 -3 -6 320 | -10 -5 -7 -2 321 | -9 -2 -5 -9 322 | -8 -3 -10 -3))) 323 | 324 | (defpattern bassline-3B () 325 | (walking-bassline 326 | '(-5 -10 -14 -2 327 | -9 -2 -1 -6 328 | -1 -6 -2 -6))) 329 | 330 | (defpattern bassline-3C () 331 | (walking-bassline 332 | '(-7 -5 -4 -2 333 | -9 -2 -5 -9 334 | -8 (-3 -8) -10 -3 335 | -5 -10 -14 -10))) 336 | 337 | (defpattern bassline-3D () 338 | (walking-bassline 339 | '(-11 -8 -6 -14 340 | -13 -6 -2 -1 341 | -6 -5 -4 -2 342 | -9 -10 -12 -14 343 | -11 -8 -6 -11))) ; sounds weird... 344 | 345 | (defun fast-line (notes) 346 | (apply 347 | 'seq 348 | (mapcar 349 | (lambda (length pitch) 350 | (etypecase pitch 351 | (integer (note 0 length (et pitch) :cfg (list :env nil :loop nil :duty (random 3) :vol 7))) 352 | (null (rst length)))) 353 | '#1=(6 . #1#) 354 | notes))) 355 | 356 | (defpattern sax-3A (:accompany ((bassline-3A))) 357 | (fast-line 358 | '(18 15 11 8 14 16 18 21 359 | 19 14 11 7 12 8 7 5 360 | 3 5 7 8 11 12 14 17 361 | 16 12 9 7 6 15 14 12))) 362 | 363 | (defpattern sax-3B (:accompany ((bassline-3B))) 364 | (fast-line 365 | '(11 14 19 23 14 17 20 24 366 | 15 17 19 22 16 20 23 25)) 367 | (bup 22 12) 368 | (note 0 6 (et 20)) 369 | (note 0 18 (et 18) :vibrato-delay 4) 370 | (rst 12)) 371 | 372 | (defpattern sax-3C (:accompany ((bassline-3C))) 373 | (fast-line 374 | '(22 21 20 19 17 15 14 12 375 | 10 20 19 14 17 15 14 17 376 | 16 12 9 4 7 4 6 15 377 | 14 12 11 9 7 9 11 14))) 378 | 379 | (defpattern sax-3D (:accompany ((bassline-3D))) 380 | (fast-line 381 | '(15 13 11 10 nil 6 8 9 382 | 11 13 15 18 22 21 20 19)) 383 | (note 0 (+ 12 4) (et 17) :vibrato-delay 6) 384 | (rst (- 12 4)) 385 | (fast-line '(19 18 17 14)) 386 | (fast-line '(15 17 nil 22 27 22 nil nil)) 387 | (rst 12) 388 | (note 0 4 (et 22)) 389 | (note 0 4 (et 23)) 390 | (note 0 (+ 4 18) (et 22)) 391 | (note 0 6 (et 18))) 392 | 393 | (defpattern chords-3A (:accompany ((sax-3A) (bassline-3A))) 394 | (chord 12 7 -0.2 t 13 10 6 3 -6 -13) 395 | (rst 12) 396 | (chord 12 7 -0.2 t 11 6 4 0 -6 -15) 397 | (rst 12) 398 | (rst 6) ; fixme, there's a bass note here 399 | (chord (+ 6 4) 6 -0.3 t 9 6 2 -8 -13) 400 | (rst (- 12 4)) 401 | (chord 24 6 -0.2 t 7 2 0 -4 -7 14) 402 | (chord 12 6 -0.2 t 10 7 2 -2 -9) 403 | (rst (+ 12 24)) 404 | (chord 12 7 -0.2 t -8 4 0 -5) 405 | (rst 12) 406 | (chord 12 7 -0.2 t 14 10 5 0 -6) 407 | (rst 12)) 408 | 409 | (defpattern chords-3B (:accompany ((sax-3B) (bassline-3B))) 410 | (chord 12 7 -0.2 t 9 6 2 -1) 411 | (rst 12) 412 | (chord 24 7 -0.2 t 7 2 0 -4 -10 -21) 413 | (chord 24 7 -0.2 t 2 -2 -5 -14 -21) 414 | (chord 24 7 -0.2 t 4 -18) 415 | (rst 12) 416 | (chord (+ 24 12) 7 -0.2 t 6 3 -2 -6 -13)) 417 | 418 | (defpattern chords-3C (:accompany ((bassline-3C) (sax-3C))) 419 | (rst 6) 420 | (chord (+ 6 4) 7 -0.2 t 7 3 0 -4 -7) 421 | (rst (- 12 4)) 422 | (chord 24 7 -0.2 t 7 2 0 -3 -7) 423 | 424 | (chord 12 7 -0.2 t 2 -2 -9 -14) 425 | (rst 12) 426 | (chord 12 7 -0.2 t 3 -2 -5 -14) 427 | (rst 12) 428 | 429 | (rst 6) 430 | (chord (+ 6 4) 7 -0.2 t 4 0 -5 -8) 431 | (rst (- 12 4)) 432 | (chord 24 8 -0.2 t 14 10 6 0 -6) 433 | 434 | (chord (+ 12 6) 7 -0.2 t 9 6 2 -1 -5 -10) 435 | (rst (- 36 6))) 436 | 437 | (defpattern chords-3D (:accompany ((bassline-3D) (sax-3D))) 438 | (rst 6) 439 | (chord (+ 6 4) 7 -0.2 t 13 8 4 1 -11) 440 | (rst (- 12 4)) 441 | (chord 24 7 -0.2 t 10 6 4 -2 -6) 442 | 443 | (chord 12 7 -0.2 t 13 6 3 -6 -13) 444 | (rst 12) 445 | (chord 12 7 -0.2 t 10 6 3 -6 -13) 446 | (rst 12) 447 | 448 | (rst 6) 449 | (chord (+ 6 4) 7 -0.2 t 7 3 0 -4 -9) 450 | (rst (- 12 4)) 451 | (chord 12 7 -0.2 t 10 5 2 0 -3) 452 | (rst 12) ; skipped random bass note 453 | (chord 12 7 -0.2 t 7 2 -2 -9) 454 | (rst 12) 455 | (chord 12 7 -0.2 t 5 2 -2 -12) 456 | (rst 12) 457 | 458 | (rst 6) 459 | (chord (+ 6 4) 7 -0.2 t 11 8 4 1 -11) 460 | (rst (- 12 4)) 461 | (chord 12 7 -0.2 t 13 10 6 4 -2 -6) 462 | (rst 12)) 463 | 464 | 465 | (defpattern section-3 () 466 | (para (bassline-3A) 467 | (sax-3A) 468 | (chords-3A)) 469 | (para (bassline-3B) 470 | (sax-3B) 471 | (chords-3B)) 472 | (para (bassline-3C) 473 | (sax-3C) 474 | (chords-3C)) 475 | (para (bassline-3D) 476 | (sax-3D) 477 | (chords-3D))) 478 | 479 | ;;; ------------------------------------------------------------ 480 | 481 | (defpattern bassline-4A () 482 | (walking-bassline 483 | '(-13 -1 -3 -6 484 | -10 -13 -14 -7 485 | -14 -9 -5 -2 486 | -3 -5 -6 -8))) 487 | 488 | (defpattern chords-4A (:accompany ((bassline-4A))) 489 | (chord (+ 12 4) 7 -0.2 t 13 10 6 3 -6 -13) 490 | (rst (- 12 4)) 491 | (chord 24 7 -0.2 nil 11 6 4 0 -6 -10) 492 | (chord 24 7 -0.2 nil 9 6 2 -1 -8 -13) 493 | (chord 24 6 -0.2 nil 7 2 -2 -4 -14) 494 | (chord (+ 12 4) 7 -0.2 t 10 7 2 -5 -9) 495 | (rst (- 12 4)) 496 | (chord (+ 12 4) 7 -0.2 t 10 7 2 -5 -9) 497 | (rst (- 12 4)) 498 | (rst 6) ; skipped bass note.. 499 | (chord (+ 6 4) 6 -0.2 t 11 7 4 0 -8) 500 | (rst (- 12 4)) 501 | (chord 24 7 -0.2 t 14 9 6 4 2 0 -6)) 502 | 503 | (defpattern sax-4A (:accompany ((bassline-4A) (chords-4A))) 504 | (note 0 1 (et 23) :cfg *sax-long*) 505 | (note 0 1 (et 24) :cfg *sax-long*) 506 | (note 0 1 (et 25) :cfg *sax-long*) 507 | (note 0 39 (et 26) :vibrato-delay 16 :cfg *sax-long*) 508 | (note 0 3 (et 25) :cfg *sax-config*) 509 | (note 0 3 (et 24)) 510 | 511 | (fast-line '(23 14 19 23 22 21 20 24)) 512 | 513 | (fast-line '(22 19 17 15 19 15)) 514 | (rst 12) 515 | 516 | (bup 26 18 :vibrato-delay 12) 517 | (note 0 6 (et 22)) 518 | (rst 6) 519 | (note 0 6 (et 18)) 520 | (note 0 12 (et 14))) 521 | 522 | (defpattern bassline-4B () 523 | (walking-bassline 524 | '(-10 -13 -14 -2 525 | -9 -2 -6 -11 526 | -13 -6 -2 -1 527 | -7 -5 -4 -2))) 528 | 529 | (defpattern chords-4B (:accompany ((bassline-4B))) 530 | (chord 24 7 -0.2 nil 9 6 2 -1 -8 -17) 531 | (chord 24 7 -0.2 nil 7 2 0 -4 -14 -19) 532 | 533 | (chord 24 7 -0.2 nil 2 -2 -5 -14 -21) 534 | (chord 24 7 -0.2 nil 4 -1 -6 -11 -18) 535 | 536 | (chord 24 7 -0.2 t 10 6 1 -6 -13) 537 | (chord (+ 12 6) 7 -0.2 t 13 10 6 -2 -6 -13) 538 | (rst (- 12 6)) 539 | 540 | (rst 6) 541 | (chord 10 7 -0.2 t 8 3 0 -3 -12) 542 | (rst 8) 543 | (chord 24 7 -0.2 t 10 5 2 0 -2)) 544 | 545 | (defpattern sax-4B (:accompany ((bassline-4B))) 546 | (fast-line '(nil 14 19 23 14 17 20 24)) 547 | (fast-line '(15 17 19 22 16 18 20 23)) 548 | (note 0 18 (et 18) :vibrato-delay 4) 549 | (fast-line '(15 13 12 11 7)) 550 | (fast-line '(12 14 15 12 19 17 14 12))) 551 | 552 | (defpattern bassline-4C () 553 | (walking-bassline 554 | '(-9 -2 -5 -8 555 | -3 -5 -6 -8 556 | -10 -12 -13 -10 557 | -11 -8 -6 -11))) 558 | 559 | (defpattern chords-4C (:accompany ((bassline-4C))) 560 | (chord 18 7 -0.2 t 10 7 2 -5 -9) 561 | (rst (+ 6 24)) 562 | (chord 24 7 -0.2 nil 4 0 -3) 563 | (chord 24 7 -0.2 nil 3 0 -3 -6) 564 | (chord 18 7 -0.2 t 2 -1 -3 -8) 565 | (rst 6) 566 | (chord 18 7 -0.2 t 7 2 -1 -3) 567 | (rst 6) 568 | (rst 6) 569 | (chord (+ 6 4) 7 -0.2 t 8 4 -1 -8 -11) 570 | (rst (- 12 4)) 571 | (chord 24 7 -0.2 t 10 6 1 -2)) 572 | 573 | (defpattern sax-4C (:accompany ((bassline-4C))) 574 | (note 0 12 (et 10) :cfg *sax-config*) 575 | (fast-line '(nil 20 19 15 nil nil)) 576 | 577 | (rst 6) 578 | (note 0 6 (et 9)) 579 | (note 0 4 (et 12)) 580 | (note 0 4 (et 16)) 581 | (note 0 4 (et 19)) 582 | (fast-line '(23 21 18 16)) 583 | 584 | (fast-line '(14 16 18 21 19 21 23)) 585 | (note 0 (+ 6 12) (et 22)) 586 | 587 | (note 0 1 (et 22.5) :cfg *sax-long*) 588 | (note 0 (- 36 1) (et 23) :vibrato-delay 10)) 589 | 590 | (defpattern bassline-4D () 591 | (walking-bassline 592 | '(-13 -6 -2 -1 593 | -6 -5 -4 -3 594 | -2 -4 -5 -7 595 | -8 -11 -6 -14))) 596 | 597 | (defpattern chords-4D (:accompany ((bassline-4D))) 598 | (chord 24 7 -0.2 t 13 10 6 3 -6 -13) 599 | (chord (+ 12 4) 7 -0.3 t 6 3 -2 -6) 600 | (rst (- 12 4)) 601 | 602 | (rst 6) 603 | (chord (+ 6 4) 7 -0.3 t 8 3 0 -7) 604 | (rst (- 12 4)) 605 | (chord 18 7 -0.3 t 10 5 2 0 -9) 606 | (rst 6) 607 | 608 | (chord 18 7 -0.2 t 7 2 -2 -9) 609 | (chord (+ 6 6) 7 -0.2 t 7 2 -2 9 -12) 610 | (rst 6) 611 | (chord 12 7 -0.2 t 3 -2 -12) 612 | 613 | (rst 6) 614 | (chord (+ 6 4) 7 -0.2 t 11 8 4 -8 -11) 615 | (rst (- 12 4)) 616 | (chord (+ 12 5) 7 -0.2 t 10 6 4 -6 -12) 617 | (rst (- 12 5))) 618 | 619 | (defpattern sax-4D (:accompany ((bassline-4D))) 620 | (fast-line '(22 18 20 22 18 15 13 11)) 621 | (fast-line '(12 14 15 12 19 17 14 12)) 622 | (note 0 18 (et 10)) 623 | (note 0 (+ 6 9) (et 19) :vibrato-delay 4) 624 | (rst (- 24 9)) 625 | (rst 6) 626 | (note 0 6 (et 13)) 627 | (note 0 4 (et 16)) 628 | (note 0 4 (et 20)) 629 | (note 0 4 (et 23)) 630 | (fast-line '(18 19 22 25))) 631 | 632 | (defpattern section-4 () 633 | (para (bassline-4A) 634 | (chords-4A) 635 | (sax-4A)) 636 | (para (bassline-4B) 637 | (chords-4B) 638 | (sax-4B)) 639 | (para (bassline-4C) 640 | (chords-4C) 641 | (sax-4C)) 642 | (para (bassline-4D) 643 | (chords-4D) 644 | (sax-4D))) 645 | 646 | (defpattern testme () 647 | (section-3) 648 | (section-4)) 649 | 650 | (defpattern bassline-5A () 651 | (walking-bassline 652 | '(-13 -1 -3 -6 653 | -10 -13 -14 -2 654 | -9 -2 -5 -9 655 | -8 -5 -3 -10))) 656 | 657 | (defpattern chords-5A (:accompany ((bassline-5A))) 658 | (chord 24 7 -0.2 nil 13 10 6 3 -6 -13) 659 | (chord 24 6 -0.2 nil 11 6 4 0 -10 -15) 660 | (chord 24 7 -0.2 nil 9 6 2 -1 -8 -17) 661 | (chord 24 6 -0.2 nil 7 2 0 -4 -14 -19) 662 | (chord (+ 12 4) 7 -0.2 t 2 -2 -5 -14 -21) 663 | (rst (- 12 4)) 664 | (chord (+ 12 4) 7 -0.3 t 5 0 -5) 665 | (rst (- 12 4)) 666 | (rst 6) 667 | (chord (+ 6 4) 7 -0.3 t 11 4 0 -5 -15) 668 | (rst (- 12 4)) 669 | (chord 24 7 -0.2 t 11 6 0 -10)) 670 | 671 | (defpattern sax-5A (:accompany ((bassline-5A) (chords-5A))) 672 | (fast-line '(23 13 15 18 14 16 17 21 673 | 19 14 11 7 12 8 7 5 674 | 3 5 7 8 10 12 14 17 675 | 16 20 19 nil 23 14 16 18))) 676 | 677 | (defpattern bassline-5B () 678 | (walking-bassline 679 | '(-5 -7 -7 -2 680 | -9 -2 -6 -11 681 | -13 -6 -2 -1 682 | -7 -5 -4 -3))) 683 | 684 | (defpattern chords-5B () 685 | (chord (+ 12 4) 7 -0.2 t 9 2 -1 -10 -17) 686 | (rst (- 12 4)) 687 | (chord 24 7 -0.2 nil 7 2 0 -4 -14 -19) 688 | (chord 24 7 -0.2 nil 2 -2 -5 -14 -21) 689 | (chord 24 7 -0.2 nil 4 -1 -6 -11 -18) 690 | (chord (+ 12 6) 7 -0.2 t 6 1 -2 -6 -13) 691 | (rst (- 12 6)) 692 | (rst 24) 693 | (rst 6) 694 | (chord (+ 6 6) 7 -0.3 t 7 3 0 -4 -9) 695 | (rst (- 12 6)) 696 | (chord 24 7 -0.2 t 7 2 0 -4 -14)) 697 | 698 | (defpattern sax-5B (:accompany ((bassline-5B) (chords-5B))) 699 | (fast-line '(19 21 23 26 20 24 22 20 700 | 19 15 17 19 16 18 20 22)) 701 | (note 0 12 (et 25)) 702 | (fast-line '(22 20 18 15)) 703 | (rst 12) 704 | (rst 24) 705 | (bup 26 12) 706 | (note 0 6 (et 14)) 707 | (note 0 6 (et 24))) 708 | 709 | (defpattern bassline-5C () 710 | (walking-bassline 711 | '(-2 -4 -5 -9 712 | -8 -3 -10 -3 713 | -5 -10 -13 -10 714 | -11 -8 -6 -14))) 715 | 716 | (defpattern chords-5C () 717 | (chord (+ 12 6) 7 -0.2 t 10 5 0 -5 -9) 718 | (rst (- 12 6)) 719 | (rst 24) 720 | (rst 6) 721 | (chord (+ 6 6) 7 -0.3 t 4 0 -5 -8) 722 | (rst (- 12 6)) 723 | (chord 24 7 -0.2 nil 14 10 5 0 -6) 724 | (chord 24 7 -0.2 t 9 6 2 -1 -3 -10) 725 | (rst 24) 726 | (rst 6) 727 | (chord (+ 6 6) 7 -0.3 t 18 11 6 -1 -4) 728 | (rst (- 12 6)) 729 | (chord 24 7 -0.2 t 19 13 10 -2 -6)) 730 | 731 | (defpattern sax-5C () 732 | (fast-line '(22 20 19 17 15 17 nil 22)) 733 | (note 0 (+ 36 6) (et 26) :vibrato-delay 10) 734 | (note 0 3 (et 25)) 735 | (note 0 3 (et 24)) 736 | (fast-line '(23 18 21 18 19 14 11 7 737 | 15 11 10 6 8 9 5 9))) 738 | 739 | (defpattern bassline-5D () 740 | (walking-bassline 741 | '(-13 -6 -2 -1 742 | -7 -5 -4 -3 743 | -2 -4 -5 -9 744 | -11 -8 -6 -11))) 745 | 746 | (defpattern chords-5D () 747 | (chord 36 7 -0.15 t 18 15 10 2 -6 -13) 748 | (rst 12) 749 | (rst 6) 750 | (chord (+ 6 6) 7 -0.2 t 12 8 1 -4 -7) 751 | (rst (- 12 6)) 752 | (chord 24 7 -0.2 nil 11 7 1 8 1 -4) 753 | (chord 12 7 -0.2 t 10 5 2 -6 -8) 754 | (rst 12) 755 | (chord 12 7 -0.2 t 10 5 0 -6 -8) 756 | (rst 12) 757 | (rst 6) 758 | (chord (+ 6 6) 7 -0.2 t 11 8 4 -1 -4 -11) 759 | (rst (- 12 6)) 760 | (chord 18 7 -0.2 t 10 6 4 -2 -6) 761 | (rst 6)) 762 | 763 | (defpattern sax-5D () 764 | (fast-line '(11 13 15 18 21 18 15 11)) 765 | (bup 20 18) 766 | (note 0 3 (et 19)) 767 | (note 0 3 (et 18)) 768 | (fast-line '(17 15 14 12)) 769 | (fast-line '(10 8 7 5 3 5 7 8)) 770 | (note 0 12 (et 15) :cfg *sax-config*) 771 | (rst 12) 772 | (rst 24)) 773 | 774 | (defpattern section-5 () 775 | (para (bassline-5A) 776 | (chords-5A) 777 | (sax-5A)) 778 | (para (bassline-5B) 779 | (chords-5B) 780 | (sax-5B)) 781 | (para (bassline-5C) 782 | (chords-5C) 783 | (sax-5C)) 784 | (para (bassline-5D) 785 | (chords-5D) 786 | (sax-5D))) 787 | 788 | (defpattern testme2 () 789 | (section-4) 790 | (section-5)) 791 | 792 | (defpattern bassline-6A () 793 | (walking-bassline '(-11 -1 -3 -6 -10 -13 -14 -2 -9 -2 -5 -9 -3 -1 0 2))) 794 | 795 | (defpattern bassline-6B () 796 | (walking-bassline '(-5 -10 -14 -2 -9 -2 -6 -11 -13 -6 -2 -1 -7 -5 -4 -3))) 797 | 798 | (defpattern bassline-6C () 799 | (walking-bassline '(-2 -4 -5 -9 -8 -3 -10 -3 -5 -3 -1 -5 -1 -8 -2 -6))) 800 | 801 | (defpattern bassline-6D () 802 | (walking-bassline '(-1 (-2 -1) -2 -1 -7 -5 -4 -3 -2 -4 -5 -9 -8 -11 -6 -14))) 803 | 804 | (defpattern chords-6A (:accompany ((bassline-6A))) 805 | (chord 12 7 -0.2 t 13 10 6 3 -6 -11) 806 | (rst 12) 807 | (chord 24 7 -0.2 nil 11 6 4 0 -10 -15) 808 | (chord 24 7 -0.2 nil 9 4 2 -1 -8 -17) 809 | (chord 24 7 -0.2 nil 7 2 0 -4 -10 -19) 810 | (chord 12 7 -0.2 t 10 7 2 -5 -9) 811 | (rst 36) 812 | (rst 6) 813 | (chord (+ 6 4) 7 -0.2 t 4 0 -5 -8 -15) 814 | (rst (- 12 4)) 815 | (chord 24 7 -0.2 t 3 0 -3 -6)) 816 | 817 | (defpattern chords-6B (:accompany ((bassline-6B))) 818 | (chord 24 7 -0.2 nil 9 2 -1 -8 -17) 819 | (chord 24 7 -0.2 nil 7 2 0 -4 -14 -19) 820 | (chord 24 7 -0.2 t 2 -2 -8 -21) 821 | (rst 24) 822 | (chord (+ 12 6) 7 -0.2 t 6 3 -9 -13) 823 | (rst (- 36 6)) 824 | (rst 6) 825 | (chord (+ 6 4) 7 -0.2 t 7 3 0 -4 -7) 826 | (rst (- 12 4)) 827 | (chord 24 7 -0.2 t 7 2 0 -3)) 828 | 829 | (defpattern chords-6C (:accompany ((bassline-6C))) 830 | (chord (+ 12 4) 7 -0.2 t 7 2 -2 -5 -9) 831 | (rst (- 36 4)) 832 | (rst 6) 833 | (chord (+ 6 4) 7 -0.2 t 4 0 -5 -15) 834 | (rst (- 12 4)) 835 | (chord 24 7 -0.2 nil 14 9 6 4 -6) 836 | (chord 48 7 -0.15 t 9 6 2 -1 -8) 837 | (rst 48)) 838 | 839 | (defpattern chords-6D (:accompany ((bassline-6D))) 840 | (chord 48 7 -0.15 t 13 10 6 3 -6 -13) 841 | (rst 6) 842 | (chord (+ 6 4) 7 -0.2 t 8 3 0 -7) 843 | (rst (- 12 4)) 844 | (chord 24 7 -0.2 nil 9 4 2 -4) 845 | (chord 12 7 -0.2 t 7 2 -2 -9) 846 | (rst 12) 847 | (chord 12 7 -0.2 t 5 2 -1 -9) 848 | (rst 12) 849 | (rst 6) 850 | (chord (+ 6 4) 7 -0.2 t 11 8 4 -11) 851 | (rst (- 12 4)) 852 | (chord 24 7 -0.2 t 10 6 4 -2)) 853 | 854 | (defpattern sax-6A (:accompany ((bassline-6A) (chords-6A))) 855 | (fast-line '(nil 6 11 15 14 16 18 21 856 | 19 14 11 7 12 8 7 5 857 | 3 5 7 8 10 12 14 17 858 | 16 20 19 nil 23 14 16 21))) 859 | 860 | (defpattern sax-6B (:accompany ((bassline-6B) (chords-6B))) 861 | (fast-line '(19 21 23 24 14 17 20 24 862 | 15 17)) 863 | (note 0 (+ 12 6) (et 19) :vibrato-delay 2) 864 | (rst (- 24 6)) 865 | (note 0 12 (et 18)) 866 | (fast-line '(15 13 11 12 14 17 867 | 22 21 20 19 17 15 14 12))) 868 | 869 | (defpattern sax-6C (:accompany ((bassline-6C) (chords-6C))) 870 | (fast-line '(10 20 19 14 17 15 14 17)) 871 | 872 | (fast-line '(16 12 9 4)) 873 | (note 0 18 (et 7) :vibrato-delay 6) 874 | (note 0 6 (et 6)) 875 | 876 | (note 0 (+ 12 4) (et 14) :vibrato-delay 6) 877 | (rst (- 6 4)) 878 | (note 0 2 (et 11)) 879 | (note 0 2 (et 14)) 880 | (note 0 2 (et 19)) 881 | (note 0 12 (et 23)) 882 | (rst 12) 883 | 884 | (rst 6) 885 | (note 0 6 (et 13)) 886 | (note 0 4 (et 16)) 887 | (note 0 4 (et 20)) 888 | (note 0 4 (et 23)) 889 | (note 0 12 (et 22)) 890 | (note 0 12 (et 25))) 891 | 892 | (defpattern sax-6D (:accompany ((bassline-6D) (chords-6D))) 893 | (bup 25 18) 894 | (note 0 3 (et 22)) 895 | (note 0 3 (et 18)) 896 | (note 0 12 (et 14)) 897 | (rst 6) 898 | (note 0 (+ 6 18) (et 26) :vibrato-delay 9) 899 | (note 0 3 (et 25)) 900 | (note 0 3 (et 24)) 901 | (fast-line '(22 20 19 17 15 17 19 22)) 902 | (note 0 (+ 12 4) (et 27) :vibrato-delay 4) 903 | (rst (- 12 4)) 904 | (rst 6) 905 | (fast-line '(27 25 23)) 906 | (note 0 18 (et 22)) 907 | (note 0 6 (et 18))) 908 | 909 | (defpattern section-6 () 910 | (para (bassline-6A) 911 | (chords-6A) 912 | (sax-6A)) 913 | (para (bassline-6B) 914 | (chords-6B) 915 | (sax-6B)) 916 | (para (bassline-6C) 917 | (chords-6C) 918 | (sax-6C)) 919 | (para (bassline-6D) 920 | (chords-6D) 921 | (sax-6D))) 922 | 923 | (defpattern bassline-7A () 924 | (walking-bassline '(-11 -1 -3 -10 -5 -10 -14 -2 -9 -2 -5 -9 -8 -6 -10 -3))) 925 | 926 | (defpattern bassline-7B () 927 | (walking-bassline '(-5 (-10 -13) -14 -2 -9 -2 -6 -9 (-13 -1) -6 -2 -1 -7 -5 -4 -3))) 928 | 929 | (defpattern bassline-7C () 930 | (walking-bassline '(-2 -4 -5 -9 -8 -15 -10 -3 -5 -3 -1 -5 0 1 2 -2))) 931 | 932 | (defpattern bassline-7D () 933 | (walking-bassline '(-1 -2 -3 -1 -7 -5 -4 -3 -2 -4 -5 -9 -4 -8 -9 -11))) 934 | 935 | (defpattern chords-7A (:accompany ((bassline-7A))) 936 | (chord (+ 4 12) 7 -0.2 t 10 6 1 -6 -13) 937 | (rst (- 12 4)) 938 | (chord 24 7 -0.2 nil 11 6 4 0 -6 -15) 939 | (chord 24 7 -0.2 nil 9 6 2 -1 -10 -17) 940 | (chord 24 7 -0.2 nil 7 2 0 -4 -14 -19) 941 | (chord 24 7 -0.2 nil 2 -2 -7 -14 -21) 942 | (chord (+ 12 4) 7 -0.2 t 5 2 -1 -13) 943 | (rst (- 12 4)) 944 | (rst 6) 945 | (chord (+ 6 6) 7 -0.2 t 7 4 0 -5 -15) 946 | (rst (- 12 6)) 947 | (chord 12 7 -0.3 t 6 3 0 -6)) 948 | 949 | (defpattern chords-7B (:accompany ((bassline-7B))) 950 | (rst 48) 951 | (rst 48) 952 | (chord (+ 12 4) 7 -0.2 t 6 3 -2 -13) 953 | (rst (+ -4 12 24)) 954 | (rst 8) 955 | (chord (+ 8 4) 7 -0.2 t 7 3 0 -4) 956 | (rst (- 12 4)) 957 | (chord 24 7 -0.2 t 7 2 -3 -14)) 958 | 959 | (defpattern chords-7C (:accompany ((bassline-7C))) 960 | (chord 12 7 -0.2 t 5 2 -2) 961 | (rst 36) 962 | (rst 6) 963 | (chord (+ 6 4) 7 -0.2 t 4 0 -5 -15) 964 | (rst (- 12 4)) 965 | (chord 24 7 -0.2 nil 6 3 0 10) 966 | (chord (+ 12 4) 7 -0.2 t 9 6 2 -1 -5 -10) 967 | (rst (- 36 4)) 968 | (chord 24 7 -0.2 nil 11 8 4 1 -1) 969 | (chord 24 7 -0.2 t 10 6 4 1 -2)) 970 | 971 | ;;; ------------------------------------------------------------ 972 | 973 | (defpattern song () 974 | (section-1) 975 | (section-2) 976 | (section-3) 977 | (section-4) 978 | (section-5)) 979 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage :6502-modes 3 | (:use) 4 | (:export :ABX :ABY :INDIRECT :RELATIVE :ZP :ZPX :ZPY :IDXI :INDI :IMM :MEM)) 5 | 6 | (defpackage :6502 7 | (:use :6502-modes) 8 | (:export :INY :ASL :PLP :STX :ORA :RTS :PLA :BVS :CPX :DEX :CLD :BCS :CMP :SEC :NOP 9 | :SBC :TSX :LDA :EOR :LSR :DEC :DEY :BNE :BEQ :INX :TXA :JMP :BRK :ANDA 10 | :BPL :INC :ROL :JSR :ROR :LDY :PHP :CLV :TXS :PHA :CPY :RTI :SED :TAX :SEI 11 | :TYA :BITA :CLC :BCC :STY :BMI :LDX :TAY :BVC :ADC :CLI :STA 12 | ;; Re-export addressing modes: 13 | :ABX :ABY :INDIRECT :RELATIVE :ZP :ZPX :ZPY :IDXI :INDI :IMM :MEM 14 | )) 15 | 16 | (defpackage :asm6502 17 | (:use :common-lisp :6502 :6502-modes) 18 | (:export #:msb #:lsb #:encode-byte #:encode-word 19 | #:promise :make-promise #:promise-name #:promise-fun #:delay #:force #:forcing 20 | #:resolve-tree 21 | #:binary-file 22 | #:context-emit #:context-address 23 | #:context-code-vector #:link 24 | #:context-find-label #:context-set-label 25 | #:*context* #:basic-context #:local-context 26 | #:emit #:label #:set-label #:label-difference #:advance-to #:align 27 | #:db #:dw #:rel #:*origin* 28 | #:opcode-cycles #:context-note-cycles #:counting-cycles #:local-context)) 29 | 30 | (defpackage :asm6502-utility 31 | (:use :common-lisp :6502 :6502-modes :asm6502) 32 | (:export #:+nmi-vector+ #:+reset-vector+ #:+irq-vector+ 33 | #:poke #:pokeword #:pushword 34 | #:wordvar #:wordval 35 | #:emit-delay #:timed-section 36 | #:asif #:condition-to-branch #:with-label #:as/until #:procedure)) 37 | 38 | (defpackage :asm6502-nes 39 | (:use :common-lisp :asm6502 :6502 :6502-modes :asm6502-utility) 40 | (:export 41 | #:+ntsc-clock-rate+ 42 | #:+ppu-cr1+ 43 | #:+ppu-cr2+ 44 | #:+ppu-status+ 45 | #:+spr-addr+ 46 | #:+spr-io+ 47 | #:+vram-scroll+ 48 | #:+vram-addr+ 49 | #:+vram-io+ 50 | #:+pulse1-control+ 51 | #:+pulse1-ramp+ 52 | #:+pulse1-fine+ 53 | #:+pulse1-coarse+ 54 | #:+pulse2-control+ 55 | #:+pulse2-ramp+ 56 | #:+pulse2-fine+ 57 | #:+pulse2-coarse+ 58 | #:+tri-cr1+ 59 | #:+tri-cr2+ 60 | #:+tri-freq1+ 61 | #:+tri-freq2+ 62 | #:+noise-control+ 63 | #:+noise-freq1+ 64 | #:+noise-freq2+ 65 | #:+dmc-control+ 66 | #:+dmc-dac+ 67 | #:+dmc-address+ 68 | #:+dmc-length+ 69 | #:+sprite-dma+ 70 | #:+papu-control+ 71 | #:+papu-irq-ctrl+ 72 | #:+joypad-1+ 73 | #:+joypad-2+ 74 | #:ines-header 75 | #:write-ines 76 | #:ppuaddr 77 | #:ppuxy 78 | #:process-dac-waveform 79 | #:emit-nsf-header)) 80 | 81 | (defpackage :nesmus 82 | (:use :common-lisp :6502 :6502-modes :asm6502 :asm6502-utility :asm6502-nes) 83 | (:export 84 | #:register 85 | #:pad-frame 86 | #:segment ;? 87 | #:translate-freq 88 | #:noteon 89 | #:cfg 90 | #:note 91 | #:silence-channel 92 | #:tri 93 | #:noise 94 | #:para 95 | #:measure 96 | #:seq 97 | #:repeat 98 | #:rst 99 | #:*tuning-root* 100 | #:get-tuning-root 101 | #:et 102 | #:kick 103 | #:snare 104 | #:hat 105 | #:thump 106 | #:shaker 107 | #:volramp 108 | #:arpeggio 109 | #:fat-arp 110 | #:funky-arp 111 | #:chord 112 | #:define-song 113 | )) 114 | --------------------------------------------------------------------------------