;; -*- Mode: Lisp; Package: User -*-

;; Originally written by ACW, modified by CWH

(defvar *scale*)
(defvar *key* 0)
(defvar *speed* 400000)

(defun piano (n)
  (fix (p (- n *key*))))

(defun p (n)
  (if (zerop n)
      1.0
      (let ((s (p (lsh n -1))))
	(* s s (if (oddp n)
		   1.059463095
		   1.0)))))

(defun init-scale ()
  (setq *scale* (make-array nil 'art-16b 177))
  (aset (piano 230) *scale* #/z)
  (aset (piano 227) *scale* #/Z)
  (aset (piano 226) *scale* #/x)
  (aset (piano 225) *scale* #/X)
  (aset (piano 224) *scale* #/c)
  (aset (piano 223) *scale* #/C)
  (aset (piano 223) *scale* #/v)
  (aset (piano 222) *scale* #/V)
  (aset (piano 221) *scale* #/b)
  (aset (piano 220) *scale* #/B)
  (aset (piano 217) *scale* #/n)
  (aset (piano 216) *scale* #/N)
  (aset (piano 215) *scale* #/m)
  (aset (piano 214) *scale* #/M)
  (aset (piano 214) *scale* #/a)
  (aset (piano 213) *scale* #/A)
  (aset (piano 212) *scale* #/s)
  (aset (piano 211) *scale* #/S)
  (aset (piano 210) *scale* #/d)
  (aset (piano 207) *scale* #/D)
  (aset (piano 207) *scale* #/f)
  (aset (piano 206) *scale* #/F)
  (aset (piano 205) *scale* #/g)
  (aset (piano 204) *scale* #/G)
  (aset (piano 203) *scale* #/h)
  (aset (piano 202) *scale* #/H)
  (aset (piano 201) *scale* #/j)
  (aset (piano 200) *scale* #/J)
  (aset (piano 200) *scale* #/q)
  (aset (piano 177) *scale* #/Q)
  (aset (piano 176) *scale* #/w)
  (aset (piano 175) *scale* #/W)
  (aset (piano 174) *scale* #/e)
  (aset (piano 173) *scale* #/E)
  (aset (piano 173) *scale* #/r)
  (aset (piano 172) *scale* #/R)
  (aset (piano 171) *scale* #/t)
  (aset (piano 170) *scale* #/T)
  (aset (piano 167) *scale* #/y)
  (aset (piano 166) *scale* #/Y)
  (aset (piano 165) *scale* #/u)
  (aset (piano 164) *scale* #/U)
  (aset (piano 164) *scale* #/k)
  (aset (piano 163) *scale* #/K)
  (aset (piano 162) *scale* #/l)
  (aset (piano 161) *scale* #/L)
  (aset (piano 160) *scale* #/i)
  (aset (piano 157) *scale* #/I)
  (aset (piano 157) *scale* #/o)
  (aset (piano 156) *scale* #/O)
  (aset (piano 155) *scale* #/p)
  (aset (piano 154) *scale* #/P))

;; We need the entire processor here, so turn off :CLOCK and :CHAOS interrupts.
;; Change when new version of PROCES installed.

(defun play-string (str &aux old-sb-state)
  (setq old-sb-state SI:%SEQUENCE-BREAK-SOURCE-ENABLE)
  (si:sb-on (logand old-sb-state 3))
  (prog (where char ii)
      R (setq where -1)
      L (setq where (1+ where))
	(if (= where (string-length str))
	    (if (and (= #/: (aref str 0))
		     (not (kbd-tyi-no-hang)))
		(go R)
		(return nil)))
	(setq char (aref str where))
	(selectq char
	  (#/')
	  (#\return)
	  (#//)
	  (#/ )
	  (#/:)
	  (#/< (setq *speed* (// *speed* 3)))
	  (#/> (setq *speed* (* *speed* 3)))
	  (#/[ (setq *speed* (lsh *speed* -1)))
	  (#/] (setq *speed* (lsh *speed* 1)))
	  (#/- (si:%beep -1 *speed*)) ;rest
	  (t (go ON)))
	(go L)
     ON (setq ii (do ((i where (1+ i)))
		     ((or (= i (string-length str))
			  (not (= (aref str i) char))) i)))
	(si:%beep (aref *scale* char) (* *speed* (- ii where)))
	(setq where (1- ii))
	(go L))
  (si:sb-on old-sb-state))

(defun play (thing)
  (cond ((stringp thing) (play-string thing))
	((symbolp thing) (play (symeval thing)))
	((listp thing) (mapc #'play thing))
	((fixp thing) (si:%beep (aref *scale* thing) *speed*))))


(defun organ (&aux (stream standard-input))
  (do ((char (tyi stream) (tyi stream))
       (tune))
      ((= char #/.) (apply #'string-append (reverse tune)))
    (select char
      (#\rubout (pop tune)
                (tv-backspace console-io-pc-ppr)
		(tv-clear-char console-io-pc-ppr))
      (#/ (cursorpos 'c)
	      (let ((rev (apply #'string-append (reverse tune))))
		(princ rev)
		(play rev)))
      (#/? (cursorpos 'c)
           (let ((rev (apply #'string-append (reverse tune))))
	     (princ rev)			;
	     (play (substring rev
			      (string-reverse-search-char #// rev)
			      (string-length rev)))))			      
      (otherwise (play-string (string-append char))
		 (push char tune))
      )))

(DEFUN INS (SEXP)
    (PRIN1 SEXP ZWEI:(INTERVAL-STREAM (POINT) (POINT) T)))

(zwei:defcom com-play-buffer "GODDAMNIT, IT'S OBVIOUS." ()
   (play zwei:(string-interval *interval*))
   zwei:dis-none)

(zwei:defcom com-play-region "Run roughshod over every buffer ever seen." ()
   (zwei:region (a b)
      (play (zwei:string-interval a b)))
   zwei:dis-none)

(init-scale)