#!/bin/bash -xe
#| -*- mode: Shell-script; indent-tabs-mode: nil; fill-column: 80 -*-
iDSK c.dsk -n

cat >imagetocpc.scm <<'EOF'
#!/bin/sh
#| -*- mode: scheme; coding: utf-8; -*-
exec gosh -I. -- $0 "$@"
|#
(use gauche.process)
(use gauche.uvector)
(use gauche.sequence)
(use sxml.adaptor) ;; for assert

(debug-print-width 4000)

(define (read-header x)
  (when (not (zero? x))
    (let1 l (read-line)
      ;; todo: comment dosn't necessarily start at line
      (if (equal? (~ l 0) #\#)
        (read-header x)
        (read-header (- x 1))))))

(define (main args)
  (with-input-from-process
      ;; todo: uh ugly - imagemagick 7 (vs 6) somehow doesn't allow
      ;; to dither anymore when converting to bitmap. S.a:
      ;; https://github.com/ImageMagick/ImageMagick/discussions/5156
      ;;#?=`(sh -c ,#`"convert ,(shell-escape-string (cadr args)) \
      ;;                       -resize \"640x200!\" pgm:- \
      ;;               |pamditherbw -atk|convert pam:- pbm:-")
      #?=`(sh -c ,#`"convert ,(shell-escape-string (cadr args)) \
                             -resize \"640x200!\" pgm:- \
                     |pamditherbw|convert pam:- pbm:-")
      (lambda()
        (read-header 2)
        (let ((src (port->uvector (current-input-port)))
              (dst (make-uvector <u8vector> (- (ash 1 14) 1))))
          (assert (= (size-of src) (/ (* 640 200) 8)))
          (dotimes (y 200)
            (dotimes (x (/ 640 8))
              (uvector-set! dst
                            (+ (* 80 (quotient y 8))
                               (* 2048 (modulo y 8)) x)
                            (~ src (+ (* y (/ 640 8)) x)))))
          (write-uvector dst))))
  0)
EOF
chmod +x imagetocpc.scm

i=0;
for f in "$@"; do
    ./imagetocpc.scm "$f" > "$i"
    iDSK c.dsk -i "$i" -c c000 -e c000
    i=$((i+1))
done

# todo: many emulators hang on printer output!
{ cat <<EOF
mode 2
print #8,"hello world from basic"
border 26:ink 0,26:ink 1,0
memory &1200-1
load "c.bin",&1200
'load "0",&c000
call &1200
EOF
}|nl -w1|unix2dos>tinylisp.bas
iDSK c.dsk -i tinylisp.bas -t 0
cat > crt0_cpc.s <<EOF
;; FILE: crt0.s
;; Generic crt0.s for a Z80
;; From SDCC..
;; Modified to suit execution on the Amstrad CPC!
;; by H. Hansen 2003
;; Original lines has been marked out!
;; Updated to SDCC v3.3.0 by Mochilote in 2013
;; (Fixed initialization of global variables)

.module crt0
        .globl  _main

        .area _HEADER (ABS)
;; Reset vector
        .org    0x1200
        jp      init

        .org    0x$(bc <<<"obase=16;ibase=16;1200+10")

init:
        ;; Initialise global variables
        call    gsinit
        ;; hack to have bigger stack (todo: copy current stack?)
        ld sp,#0x8000-1
        call    _main
        jp      _exit

;; Ordering of segments for the linker.
        .area   _HOME
        .area   _CODE
        .area   _INITIALIZER
        .area   _GSINIT
        .area   _GSFINAL

        .area   _DATA
        .area   _INITIALIZED
        .area   _BSEG
        .area   _BSS
        .area   _HEAP

  .area   _CODE
__clock::
        ret

_exit::
        ret

        .area   _GSINIT
gsinit::
        ld      bc, #l__INITIALIZER
        ld      a, b
        or      a, c
        jr      Z, gsinit_next
        ld      de, #s__INITIALIZED
        ld      hl, #s__INITIALIZER
        ldir
gsinit_next:

        .area   _GSFINAL
        ret
EOF
sdasz80 -go crt0_cpc.s
cat > util.s <<'EOF'
.area _CODE
_putchar::
        ld a,l
        call    0xbb5a
1$:
        ; output to printer
        ; (todo: many emulators hang on printer output!)
        call 0xbd2b
        jp nc,1$
        ret

_getchar::
        ; ld a,#63
        ; call 0xbb5a
        call 0xbb06
        ld d,#0x0
        ld e,a
        ret

;; load_file(char* fname, char* address)
;; fname => hl
;; address => de
_load_file::
        push de
        push hl
        call _strlen
        pop hl
        ; result in de
        ld b,e

        ; firmware function to open a file for reading
        ; B = length of the filename in characters
        ; HL = address of the start of the filename
        call #0xbc77 ;;cas_in_open

        ;; firmware function to load the entire file
        ;; this will work with files that have a AMSDOS header (ASCII
        ;; files do not have a header)
        ;; HL = load address
        ;; read file
        pop de
        ld h,d
        ld l,e
        call #0xbc83 ;;cas_in_direct

        ;; firmware function to close a file opened for reading
        call #0xbc7a ;;cas_in_close
        ret

_JP_HL::
        jp (hl)
EOF
sdasz80 -go util.s

cat > c.c <<EOF
/* tinylisp-float-opt.c with single float precision NaN boxing
   (optimized version) by Robert A. van Engelen 2022 */

/*
BSD 3-Clause License

Copyright (c) 2021, Robert van Engelen
Copyright (c) 2025, Jens Thiele
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

1. Redistributions of source code must retain the above copyright notice, this
   list of conditions and the following disclaimer.

2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation
   and/or other materials provided with the distribution.

3. Neither the name of the copyright holder nor the names of its
   contributors may be used to endorse or promote products derived from
   this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*/

#include <stdint.h>
#include <stdlib.h>
#include <stdio.h>
#include <string.h>

void myexit(void)
{
  /* printf("myexit: todo\r\n"); */
  while(1)
        ;
}

void abort(void)
{
        printf("abort: todo\r\n");
        myexit();
}

int mysscanf(char* buf, char *fmt, float* f, int* n)
{
        if (((buf[0]=='-')&&('0' <= buf[1])&&(buf[1] <= '9'))
            ||(('0' <= buf[0]) && (buf[0] <= '9'))) {
           *f=atof(buf);
           *n=strlen(buf);
           return 1;
        }
        return 0;
}

const char* input_s;
int input_pos=0;
int mygetchar()
{
   if (input_pos<strlen(input_s)) {
      int r=input_s[input_pos];
      input_pos++;
      return r;
   }
   return getchar();
}

#define I uint16_t
#define L float
#define T(x) *(uint32_t*)&x>>20
#define A (char*)cell
#define N 2048 /* N should not exceed 262144 = 2^20/4 cells = 1048576 bytes */
I hp=0,sp=N,ATOM=0x7fc,PRIM=0x7fd,CONS=0x7fe,CLOS=0x7ff,NIL=0xfff;
L cell[N],nil,tru,err,env;
L box(I t,I i) { L x; *(uint32_t*)&x = (uint32_t)t<<20|i; return x; }
I ord(L x) { return *(uint32_t*)&x & 0xfffff; }
L num(L n) { return n; }
I equ(L x,L y) { return *(uint32_t*)&x == *(uint32_t*)&y; }
L atom(const char *s) {
 I i = 0; while (i < hp && strcmp(A+i,s)) i += strlen(A+i)+1;
 if (i == hp && (hp += strlen(strcpy(A+i,s))+1) > sp<<2) abort();
 return box(ATOM,i);
}
L cons(L x,L y) {
  cell[--sp] = x; cell[--sp] = y;
  if (hp > sp<<2) abort(); return box(CONS,sp);
}
L car(L p) { return (T(p)&~(CONS^CLOS)) == CONS ? cell[ord(p)+1] : err; }
L cdr(L p) { return (T(p)&~(CONS^CLOS)) == CONS ? cell[ord(p)] : err; }
L pair(L v,L x,L e) { return cons(cons(v,x),e); }
L closure(L v,L x,L e) { return box(CLOS,ord(pair(v,x,equ(e,env) ? nil : e))); }
L assoc(L v,L e) {
  while (T(e) == CONS && !equ(v,car(car(e)))) e = cdr(e);
  return T(e) == CONS ? cdr(car(e)) : err;
}
I not(L x) { return T(x) == NIL; }
I let(L x) { return !not(x) && !not(cdr(x)); }
L eval(L,L),parse();
L evlis(L t,L e) {
 L s,*p;
 for (s = nil,p = &s; T(t) == CONS; p = cell+sp,t = cdr(t))
     *p = cons(eval(car(t),e),nil);
 if (T(t) == ATOM) *p = assoc(t,e);
 return s;
}
L evarg(L *t,L *e,I *a) {
 L x;
 if (T(*t) == ATOM) *t = assoc(*t,*e),*a = 1;
 x = car(*t); *t = cdr(*t);
 return *a ? x : eval(x,*e);
}
uint16_t globali;
L call(L f) {
  globali=f;
  __asm
        ld hl,(_globali)
        call _JP_HL
  __endasm;
  return (L)0;
}
L poke(L x,L y) {
  uint16_t a=x;
  char v=y;
  *((char*)a)=v;
  return y;
}
L peek(L x) {
  uint16_t a=x;
  return *((char*)a);
}
L lputchar(L x) {
  putchar((char) x);
  return x;
}

L f_eval(L t,L *e) { I a = 0; return evarg(&t,e,&a); }
L f_quote(L t,L *_) { return car(t); }
L f_cons(L t,L *e) {
  I a = 0; L x = evarg(&t,e,&a); return cons(x,evarg(&t,e,&a));
}
L f_car(L t,L *e) { I a = 0; return car(evarg(&t,e,&a)); }
L f_cdr(L t,L *e) { I a = 0; return cdr(evarg(&t,e,&a)); }
L f_add(L t,L *e) {
  I a = 0; L n = evarg(&t,e,&a); while (!not(t)) n += evarg(&t,e,&a);
  return num(n);
}
L f_sub(L t,L *e) {
  I a = 0; L n = evarg(&t,e,&a); while (!not(t)) n -= evarg(&t,e,&a);
  return num(n);
}
L f_mul(L t,L *e) {
  I a = 0; L n = evarg(&t,e,&a); while (!not(t)) n *= evarg(&t,e,&a);
  return num(n);
}
L f_div(L t,L *e) {
  I a = 0; L n = evarg(&t,e,&a); while (!not(t)) n /= evarg(&t,e,&a);
  return num(n);
}
L f_int(L t,L *e) {
  I a = 0; L n = evarg(&t,e,&a); return n<1e16 && n>-1e16 ? (int)n : n;
}
L f_lt(L t,L *e) {
  I a = 0; L n = evarg(&t,e,&a); return n - evarg(&t,e,&a) < 0 ? tru : nil;
}
L f_eq(L t,L *e) {
  I a = 0; L x = evarg(&t,e,&a); return equ(x,evarg(&t,e,&a)) ? tru : nil;
}
L f_pair(L t,L *e) {
  I a = 0; L x = evarg(&t,e,&a); return T(x) == CONS ? tru : nil;
}
L f_not(L t,L *e) {
  I a = 0; return not(evarg(&t,e,&a)) ? tru : nil;
}
L f_or(L t,L *e) {
  I a = 0; L x = nil; while (!not(t) && not(x)) x = evarg(&t,e,&a); return x;
}
L f_and(L t,L *e) {
  I a = 0; L x = tru; while (!not(t) && !not(x)) x = evarg(&t,e,&a); return x;
}
L f_cond(L t,L *e) {
  while (not(eval(car(car(t)),*e))) t = cdr(t); return car(cdr(car(t)));
}
L f_if(L t,L *e) {
  return car(cdr(not(eval(car(t),*e)) ? cdr(t) : t));
}
L f_leta(L t,L *e) {
  for (;let(t); t = cdr(t)) *e = pair(car(car(t)),eval(car(cdr(car(t))),*e),*e);
  return car(t);
}
L f_lambda(L t,L *e) { return closure(car(t),car(cdr(t)),*e); }
L f_define(L t,L *e) {
  env = pair(car(t),eval(car(cdr(t)),*e),env); return car(t);
}
L f_call(L t,L *e) { I a = 0; return call(evarg(&t,e,&a)); }
L f_poke(L t,L *e) {
  I a = 0; L x = evarg(&t,e,&a); return poke(x,evarg(&t,e,&a));
}
L f_peek(L t,L *e) { I a = 0; return peek(evarg(&t,e,&a)); }
L f_begin(L t, L *e) {
  for (; let(t); t=cdr(t)) eval(car(t),*e);
  return car(t);
}
L f_putchar(L t, L *e) { I a = 0; return lputchar(evarg(&t,e,&a)); }
void load_file(char* fname, char* addr);
L f_load(L t, L *e) {
  I a = 0;
  L fnl=evarg(&t,e,&a);
  L r=evarg(&t,e,&a);
  char filename[8+1+3+1];
  char i;
  for (i=0;i<8+1+3+1;++i) filename[i]=0;
  i=0;
  L c=car(fnl);
  filename[i]=(char)c;
  i=i+1;
  while (1) {
        if (not(fnl = cdr(fnl))) break;
        filename[i]=(char)car(fnl);
        ++i;
  }
  load_file(filename, (char*)(uint16_t)r);
  return r;
}

L f_getchar(L t, L *e) { int c=getchar(); return (L)c; }
/* todo: really echo_read _and_ quiet? */
char echo_read=1;
L f_echo(L t, L *e) {
  I a = 0; L x = evarg(&t,e,&a); echo_read=(uint16_t)x; return x;
}
char quiet=0;
L f_quiet(L t, L *e) {
  I a = 0; L x = evarg(&t,e,&a); quiet=(uint16_t)x; return x;
}

struct { const char *s; L (*f)(L,L*); short t; } prim[]={
{"eval",  f_eval,  1},{"quote", f_quote, 0},{"cons", f_cons,0},
{"car", f_car, 0},{"cdr",f_cdr,0},{"+",   f_add, 0},
{"-",     f_sub,   0},{"*",     f_mul,   0},{"/",    f_div, 0},
{"int", f_int, 0},{"<",  f_lt, 0},{"eq?", f_eq,  0},
{"or",    f_or,    0},{"and",   f_and,   0},{"not",  f_not, 0},
{"cond",f_cond,1},{"if", f_if, 1},{"let*",f_leta,1},
{"lambda",f_lambda,0},{"define",f_define,0},{"pair?",f_pair,0},
{"call",f_call,0},{"poke",f_poke,0},{"peek",f_peek,0},
{"begin",f_begin,1},{"putchar",f_putchar,0},{"load",f_load,0},
{"getchar",f_getchar,0},{"set-echo!",f_echo,0},{"set-quiet!",f_quiet,0},
{0}};

void assign(L v,L x,L e) {
     while (!equ(v,car(car(e)))) e = cdr(e); cell[ord(car(e))] = x;
}
L eval(L x,L e) {
 I a; L f,v,d,g = nil,h;
 while (1) {
  if (T(x) == ATOM) return assoc(x,e);
  if (T(x) != CONS) return x;
  f = eval(car(x),e); x = cdr(x);
  if (T(f) == PRIM) {
   x = prim[ord(f)].f(x,&e);
   if (prim[ord(f)].t) continue;
   return x;
  }
  if (T(f) != CLOS) return err;
  v = car(car(f));
  if (equ(f,g)) d = e;
  else if (not(d = cdr(f))) d = env;
  for (a = 0; T(v) == CONS; v = cdr(v)) d = pair(car(v),evarg(&x,&e,&a),d);
  if (T(v) == ATOM) d = pair(v,a ? x : evlis(x,e),d);
  if (equ(f,g)) {
   for (; !equ(d,e) && sp == ord(d); d = cdr(d),sp += 4)
       assign(car(car(d)),cdr(car(d)),e);
   for (; !equ(d,h) && sp == ord(d); d = cdr(d)) sp += 4;
  }
  x = cdr(car(f)); e = d; g = f; h = e;
 }
}
char buf[40],see = ' ';
void look() {
     int c = mygetchar();
     if (echo_read) {
        putchar(c);
        if (c=='\r') putchar('\n');
     }
     see = c;
     if (c == EOF) myexit();
}
I seeing(char c) { return c == ' ' ? see > 0 && see <= c : see == c; }
char get() { char c = see; look(); return c; }
char scan() {
 int i = 0;
 while (seeing(' ')) look();
 if (seeing('(') || seeing(')') || seeing('\'')) buf[i++] = get();
 else do buf[i++] = get();
 while (i < 39 && !seeing('(') && !seeing(')') && !seeing(' '));
 return buf[i] = 0,*buf;
}
L Read() { return scan(),parse(); }
L list() {
 L t,*p;
 for (t = nil,p = &t; ; *p = cons(parse(),nil),p = cell+sp) {
  if (scan() == ')') return t;
  if (*buf == '.' && !buf[1]) return *p = Read(),scan(),t;
 }
}
L parse() {
 L n; int i;
 if (*buf == '(') return list();
 if (*buf == '\'') return cons(atom("quote"),cons(Read(),nil));
 return mysscanf(buf,"%g%n",&n,&i) > 0 && !buf[i] ? n : atom(buf);
}
void print(L);
void printlist(L t) {
 for (putchar('('); ; putchar(' ')) {
  print(car(t));
  if (not(t = cdr(t))) break;
  if (T(t) != CONS) { printf(" . "); print(t); break; }
 }
 putchar(')');
}
void print(L x) {
 if (quiet) return;
 if (T(x) == NIL) printf("()");
 else if (T(x) == ATOM) printf("%s",A+ord(x));
 else if (T(x) == PRIM) printf("<%s>",prim[ord(x)].s);
 else if (T(x) == CONS) printlist(x);
 else if (T(x) == CLOS) printf("{%u}",ord(x));
 else if (x>=0) printf("%lu",(uint32_t)x);
 else printf("-%lu",(uint32_t)(-x));
}
void gc() { sp = ord(env); }

void main() {
 I i;
 printf("tinylisp 0.0.13");
 input_s="\
(define null? not)\r\
(define err? (lambda (x) (eq? x 'ERR)))\r\
(define number? (lambda (x) (eq? (* 0 x) 0)))\r\
(define symbol? (lambda (x)\r\
(and x (not (err? x)) (not (number? x)) (not (pair? x)))))\r\
(define list? (lambda (x) (if (pair? x) (list? (cdr x)) (not x))))\r\
(define equal? (lambda (x y)\r\
 (or (eq? x y) (and (pair? x) (pair? y)\r\
  (equal? (car x) (car y))\r\
  (equal? (cdr x) (cdr y))))))\r\
(define negate (lambda (n) (- 0 n)))\r\
(define > (lambda (x y) (< y x)))\r\
(define <= (lambda (x y) (not (< y x))))\r\
(define >= (lambda (x y) (not (< x y))))\r\
(define = (lambda (x y) (eq? (- x y) 0)))\r\
(define list (lambda args args))\r\
(define cadr (lambda (x) (car (cdr x))))\r\
(define caddr (lambda (x) (car (cdr (cdr x)))))\r\
(define length-tr (lambda (t n) (if t (length-tr (cdr t) (+ n 1)) n)))\r\
(define length (lambda (t) (length-tr t 0)))\r\
(define append1 (lambda (s t) (if s (cons (car s) (append1 (cdr s) t)) t)))\r\
(define append (lambda (t . args) (if args (append1 t (append . args)) t)))\r\
(define reverse-tr (lambda (r t)\r\
 (if t (reverse-tr (cons (car t) r) (cdr t)) r)))\r\
(define reverse (lambda (t) (reverse-tr () t)))\r\
(define any? (lambda (f t)\r\
 (if t (if (f (car t)) #t (any? f (cdr t))) ())))\r\
(define mapcar (lambda(f t) (if t (cons (f (car t)) (mapcar f (cdr t))) ())))\r\
(define map (lambda (f . args)\r\
 (if (any? null? args)\r\
  ()\r\
  (let*\r\
   (x (mapcar car args))\r\
   (t (mapcar cdr args))\r\
   (cons (f . x) (map f . t))))))\r\
(define iota2 (lambda(i r)\r\
 (if (< 0 i)\r\
  (iota2 (- i 1) (cons i r))\r\
  (cons i r))))\r\
(define iota (lambda(c) (iota2 (- c 1) ())))\r\
(define cls (lambda() (begin (call 47980) (call 48148))))\r\
(define display-image (lambda(x)\r\
 (if (< x $i) (begin (load (list (+ x 48)) 49152) (display-image (+ x 1)))\r\
  x)))\r\
(set-echo! 0)\r\
(set-quiet! 1)\r\
(cls)\r\
(display-image 0)\r\
(getchar)\r\
(cls)\r\
(set-echo! 1)\r\
(set-quiet! 0)\r\
"
#if 0
"(map cons (iota 5) (iota 5))\r\
(define fact (lambda(n) (if (< n 2) 1 (* n (fact (- n 1))))))\r(fact 7)\r\
(define sum2 (lambda(n a) (if (< n 1) a (sum2 (- n 1) (+ a n)))))\r\
(define sum (lambda(n) (sum2 n 0)))\r\
(sum 100)\r(/ (* 101 100) 2)\r\
(poke 49152 255)\r\
(peek 49152)\r\
(define fill (lambda(a c v)\r\
 (if (< c 1) 0 (begin (poke a v) (fill (+ a 1) (- c 1) v)))))\r\
(fill 49152 80)\r\
(begin (putchar 72)(putchar 101)(putchar 108)\r\
 (putchar 108)(putchar 111)(putchar 13)(putchar 10))\r"
#endif
;

 nil = box(NIL,0); err = atom("ERR"); tru = atom("#t"); env = pair(tru,tru,nil);
 for (i = 0; prim[i].s; ++i) env = pair(atom(prim[i].s),box(PRIM,i),env);
 while (1) {
       if (!quiet) printf("\r\n%u>",sp-hp/4);
       print(eval(Read(),env));
       gc();
 }
}
EOF
sdcc -mz80 \
     --code-loc 0x$(bc <<<"obase=16;ibase=16;1200+38") \
     --data-loc 0 \
     --no-std-crt0 crt0_cpc.rel util.rel c.c
makebin -yo A -p c.ihx|tail -c +$((0x1200+1))>c.bin
iDSK c.dsk -i c.bin -e 1200 -c 1200

rm -vf printer.txt
mame cpc664 -flop1 c.dsk -skip_gameinfo -ab '\n\nrun "tinylisp\n' \
     -prin printer.txt
dos2unix < printer.txt|cat -v