(defun brainf-compile (start program) 
  (if (null program)
      start
      (let front-restp (brainf-front program)
           front       (first front-restp)
           restp       (second front-restp)

           (if (eq '\[ front) 

; BUG: find-before and find-after to not observe nested []

               (let body (find-before '\] restp)
                    restb (find-after '\] restp)
                    (brainf-compile (list 'bf-loop
                                          (list 'quote
                                                (brainf-compile 'START body))
                                          start)
                                    restb))

                (brainf-compile (list (implode (list 'bf front)) start)
                                 restp)))))

(defun brainf-front (program)
  (list (car program) (cdr program)))

(defun test-compile (prog)
  (say (list prog '===>  (brainf-compile 'START (explode prog)))))

(defun find-before (a lst)
       (if (null lst)
           'nil
           (if (eq a (car lst))
               'nil
               (cons (car lst) (find-before a (cdr lst))))))

(assert (eq 'one (implode (find-before '- (explode 'one-two-three)))))

(defun find-after (a lst)
       (if (null lst)
           'nil
           (if (eq a (car lst))
               (cdr lst)
               (find-after a (cdr lst)))))

(assert (eq 'two-three (implode (find-after '- (explode 'one-two-three)))))

(test-compile 'a)
(test-compile 'abc)
(test-compile 'abc<>+-.)
(test-compile 'a\[bc\]<>+-.)

(defun bf-loop (clause start)
  (let START start
       left  (first START)
       cur   (car left)
       (if (null cur)  ; quit when current value is zero
           START
           (bf-loop clause (eval clause)))))


(defun say-bf-run (program)
  (let
       _ (say (list '<<< program))
       f (brainf-compile 'START (explode program))
       _ (say (list '=== f))
       START '( ( () ) () )
       z (eval f)
       _ (say (list '>>> (mapcar (reverse (cdr (first z))) roman) ': (roman (car (first z))) ': (mapcar (second z) roman)))
       z))

(defun bf< (tltr)        ; tape left and tape right
  (let tl (first tltr)   ; first tl is the "current" tape slot
       tr (second tltr)  ; tape going to the right
       z (if (null (cdr tl))
             (list (list (list)) (cons (car tl) tr))
             (list (cdr tl) (cons (car tl) tr)))
       ;_ (say (list 'tl= tl 'tr= tr 'z= z))
       z ))

(say (list '========== (bf< '((()) ()))))
(assert (equal '((()) (())) (bf< '((()) ()))))
(assert (equal '(((1)) (())) (bf<   '((() (1)) ())  )))

(defun bf> (tltr)        ; tape left and tape right
  (let tl (first tltr)   ; first tl is the "current" tape slot
       tr (second tltr)  ; tape going to the right
       (if (null tr)
           (list (cons (list) tl) (list))
           (list (cons (car tr) tl) (cdr tr)))))

(assert (equal '((() ()) ()) (bf>     '( (()) () )    )))

(defun bf+ (tltr)        ; tape left and tape right
  (let tl (first tltr)   ; first tl is the "current" tape slot
       tr (second tltr)  ; tape going to the right
       (list (cons (cons '1 (car tl))
                   (cdr tl))
             tr)))

(defun bf- (tltr)        ; tape left and tape right
  (let tl (first tltr)   ; first tl is the "current" tape slot
       tr (second tltr)  ; tape going to the right
       (list (cons (cdr (car tl))
                   (cdr tl))
             tr)))

          
(say (list '+++++++++++   (bf+   '( (()) () )   )))
(assert (equal  '( ((1)) () )  (bf+   '( (()) () )   )))
(assert (equal  '( ((1 1)) () )  (bf+   '( ((1)) () )   )))

(defun Run+>+>+ ()
  (let f (brainf-compile 'START  (explode '+>+>+))
       _ (say (list '========f f))
       START '( ( () ) () )
       z (eval f) 
       _ (say (list '========z z))
       z))
(say (list 'RUN====>  (Run+>+>+)))
(assert (equal '( ((1) (1) (1)) () )  (Run+>+>+)))
(assert (equal '( ((1) (1) (1)) () )  (Run+>+>+)))

(assert (equal '((nil nil nil) nil)  (say-bf-run '+->+->+- )))

(assert (equal '((nil nil nil) nil)  (say-bf-run '+>+>+-<-<->> )))

(def 'chars '(
  ^@	^A	^B	^C	^D	^E	^F	^G
  ^H	^I	^J	^K	^L	^M	^N	^O
  ^P	^Q	^R	^S	^T	^U	^V	^W
  ^X	^Y	^Z	^?	^?	^?	^?	^?

  \   	!	?	?	?	?	?	?
  ?	?	?	?	?	?	?	?
  0	1	2	3	4	5	6	7
  8	9	?	?	?	?	?	?

  @	A	B	C	D	E	F	G
  H	I	J	K	L	M	N	O
  P	Q	R	S	T	U	V	W
  X	Y	Z	?	?	?	?	?

  @	a	b	c	d	e	f	g
  h	i	j	k	l	m	n	o
  p	q	r	s	t	u	v	w
  x	y	z	?	?	?	?	?
))

(defun nth (lst n)
  (if (null n)
      (car lst)
      (nth (cdr lst) (cdr n))))

(let 2 '(i i)
     8 (* (* 2 2) 2)
     64 (* 8 8)
     (assert (eq '\@ (nth chars 64)))
)

(defun repeat-list (lst n)
  (if (null n)
      'nil
      (append lst (repeat-list lst (cdr n)))))

(defun repeat-element (e n)
  (if (null n)
      'nil
      (cons e (repeat-element e (cdr n)))))

(assert (equal '(x y z  x y z  x y z x  y z) 
               (say (repeat-list '(x y z) '(4 3 2 1)))))
(assert (equal '(xyz xyz xyz xyz) 
               (say (repeat-element 'xyz '(4 3 2 1)))))


(defun bf. (tltr)        ; tape left and tape right
  (let tl (first tltr)   ; first tl is the "current" tape slot
       tr (second tltr)  ; tape going to the right
       _ (say (list 'BF-OUTPUT: (nth chars (car tl))))
       tltr))

(let 2 '(i i)
     8 (* (* 2 2) 2)
     64 (* 8 8)
     (say-bf-run (implode (list
         (implode (repeat-element '+ 64))
         '.+.+.+.  ))))


( say-bf-run '+++[>+<-]>. )
( say-bf-run '++++++++++++[->+++++++>+++++++++<<]>-.>[->+>+>+>+>+<<<<<]>++++++++.>-------.<--.>>.---.>++.>-----.>++++++++[->++++<]>.<<<<<<<<.>>++.>.>.>.>>++++++++++.  )

(say 'OKAY!)