;; -*- Mode:LISP; Package:HACKS; Base:8; Readtable:ZL -*-

;; Originally written by ACW, modified by CWH
;; Modified again by DLA.

(defvar *scale*)
(defvar *key* 0)
(defvar *initial-speed* 400000)			;Normal speed
(defvar *speed* *initial-speed*)		;Current speed
(defvar *organ-initial-speed*)			;Speed when ORGAN was last called

(defvar *organ-input-buffer* (make-string #o300 :fill-pointer 0))

(defvar *organ-speed-stack* (make-array #o300 :fill-pointer 0))

(defvar *organ-initial-right*)			;Variables for rubout handling
(defvar *organ-initial-down*)

(defun piano (n)
  (fix (* .5878590257 (piano-1 (- n *key*)))))	;A = 440 4 Jan 1981

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

(defvar *scale*
  (let ((arr (make-array #o177 :type 'art-16b)))
    (aset (piano 230) arr #/z)
    (aset (piano 227) arr #/Z)
    (aset (piano 226) arr #/x)
    (aset (piano 225) arr #/X)
    (aset (piano 224) arr #/c)
    (aset (piano 223) arr #/C)
    (aset (piano 223) arr #/v)
    (aset (piano 222) arr #/V)
    (aset (piano 221) arr #/b)
    (aset (piano 220) arr #/B)
    (aset (piano 217) arr #/n)
    (aset (piano 216) arr #/N)
    (aset (piano 215) arr #/m)
    (aset (piano 214) arr #/M)
    (aset (piano 214) arr #/a)
    (aset (piano 213) arr #/A)
    (aset (piano 212) arr #/s)
    (aset (piano 211) arr #/S)
    (aset (piano 210) arr #/d)
    (aset (piano 207) arr #/D)
    (aset (piano 207) arr #/f)
    (aset (piano 206) arr #/F)
    (aset (piano 205) arr #/g)
    (aset (piano 204) arr #/G)
    (aset (piano 203) arr #/h)
    (aset (piano 202) arr #/H)
    (aset (piano 201) arr #/j)
    (aset (piano 200) arr #/J)
    (aset (piano 200) arr #/q)
    (aset (piano 177) arr #/Q)
    (aset (piano 176) arr #/w)
    (aset (piano 175) arr #/W)
    (aset (piano 174) arr #/e)
    (aset (piano 173) arr #/E)
    (aset (piano 173) arr #/r)
    (aset (piano 172) arr #/R)
    (aset (piano 171) arr #/t)
    (aset (piano 170) arr #/T)
    (aset (piano 167) arr #/y)
    (aset (piano 166) arr #/Y)
    (aset (piano 165) arr #/u)
    (aset (piano 164) arr #/U)
    (aset (piano 164) arr #/k)
    (aset (piano 163) arr #/K)
    (aset (piano 162) arr #/l)
    (aset (piano 161) arr #/L)
    (aset (piano 160) arr #/i)
    (aset (piano 157) arr #/I)
    (aset (piano 157) arr #/o)
    (aset (piano 156) arr #/O)
    (aset (piano 155) arr #/p)
    (aset (piano 154) arr #/P) arr))
  
;; We need the entire processor here, so turn off :CLOCK and :CHAOS interrupts.
;; Change when new version of PROCES installed.
  
  
(defun play-string (str)
  (with-real-time
    (prog (where char ii (repeat (= (aref str 0) #/:)))
       R (setq where -1)
       L (setq where (1+ where))
	  (if (= where (string-length str))
	      (if (and repeat
		       (not (send *terminal-io* :tyi-no-hang)))
		  (go R)
		  (return nil)))
	  (setq char (aref str where))
	  (and (> char 177) (go L))
	  (selectq char
	    (#/')
	    (#//)
	    (#/ )
	    (#/:)
	    (#/CR)
	    (#/@ (setq *speed* *initial-speed*))
	    (#/< (setq *speed* (truncate *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))))

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

(defun organ (&aux (buffer *organ-input-buffer*)
		   (speed-stack *organ-speed-stack*)
	           (stream standard-input)
		   (temp-array (make-array 1 ':type 'art-string)))
  (organ-note-initial-cursorpos stream)
  (setf (fill-pointer buffer) 0)		;Flush buffer contents
  (setf (fill-pointer speed-stack) 0)
  (do ((char (send stream :tyi) (send stream :tyi)))
      ((= char #/.)
       (string-append buffer))
    (selectq char
      (#/rubout (organ-do-rubout buffer speed-stack stream))
      ((#/return #/tab)
       (send stream :tyo char)
       (vector-push-extend char buffer))
      ((#/form 554 514)
       (send stream :clear-window)
       (organ-note-initial-cursorpos stream)
       (princ buffer))
      ((#/? #/help)
       (send stream :clear-window)
       (princ "
Welcome to the ORGAN.  The keyboard is now an organ.  Most of the keys play
notes, but the following have special meanings.  The most notable of these are
the following:

:       If this is the first character in the string, the string will
        repeat when played.
@       Resets speed to the initial speed.
<       Speeds you up by a factor of 3.
>       Slows you down by a factor of 3.
[       Speeds you up by a factor of 2.
]       Slows you down by a factor of 2.
-       Plays a rest.
RUBOUT  Allows you to erase your mistakes.
.       Stops.  ORGAN returns a string which is your tune.  This tune can
        be played with the PLAY function.

")
	   (organ-note-initial-cursorpos stream)
	   (princ buffer))
      (otherwise
       (cond ((< char #o200)
	      (send stream :tyo char)
	      (and (memq char '(#/< #/> #/[ #/] #/@))
		   (vector-push-extend *speed* speed-stack))
	      (aset char temp-array 0)
	      (OR (CHAR-EQUAL CHAR #/:)		;This would play forever...
		  (play-string temp-array))
	      (vector-push-extend char buffer))
	     (t (tv:beep)))))))


(defun organ-do-rubout (buffer speed-stack stream &aux r d char)
  (cond ((plusp (array-leader buffer 0))
	 (setq char (vector-pop buffer))
	 (multiple-value (r d)
	   (send stream :read-cursorpos))	;in PIXEL!!
	 (cond ((or (zerop r)
		    (= char #/tab))
		(send stream :set-cursorpos *organ-initial-right* *organ-initial-down*)
		(send stream :string-out buffer))
	       (t (send stream :set-cursorpos
			       (- r (send stream :character-width char))
			       d)
		  (send stream :clear-rest-of-line)))
	 (and (memq char '(#/< #/> #/[ #/] #/@))
	      (setq *speed* (vector-pop speed-stack))))
	(t (tv:beep))))				;Is this the right thing??

(defun organ-note-initial-speed ()
  (setq *organ-initial-speed* *speed*))

(defun organ-figure-out-speed (buffer temp-array)
  (setq *speed* *organ-initial-speed*)
  (dotimes (x (string-length buffer))
    (and (mem #'= (aref buffer x) '(#/< #/> #/[ #/] #/@))
	 (progn (aset (aref buffer x) temp-array 0)
		(play-string temp-array)))))

(defun organ-note-initial-cursorpos (stream)
  (multiple-value (*organ-initial-right* *organ-initial-down*)
    (send stream :read-cursorpos)))


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

(zwei:defcom com-play-region "Plays the region with the ORGAN program." ()
   (zwei:region (a b)
      (play (zwei:string-interval a b)))
   zwei:dis-none)

;Thank you, Khyai Udin Mas
(defvar pelog-scale
  (let ((arr (make-array 177 ':type 'art-16b)))
    (aset 2340 arr #/a)
    (aset 2340 arr #/A)
    (aset 2200 arr #/s)
    (aset 2200 arr #/S)
    (aset 2030 arr #/d)
    (aset 2030 arr #/D)
    (aset 1540 arr #/f)
    (aset 1540 arr #/F)
    (aset 1444 arr #/g)
    (aset 1444 arr #/G)
    (aset 1377 arr #/h)
    (aset 1377 arr #/H)
    (aset 1273 arr #/j)
    (aset 1273 arr #/J)
    arr))

(defun gamelan ()
  (let ((*scale* pelog-scale))
    (organ)))

(defun play-gamelan (thing)
  (let ((*scale* pelog-scale))
    (play thing)))