6502/PLASMA
1
0
Fork 0
mirror of https://github.com/dschmenk/PLASMA.git synced 2025-04-02 12:30:34 +00:00
Code Issues Projects Releases Wiki Activity

Add LORES graphics to DRAWL

Browse Source
This commit is contained in:
David Schmenk 2024-07-22 16:22:46 -07:00
parent e9bde21346
commit 9592ac3f2c
6 changed files with 133 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
src/lisp/drawl.pla
View File

@ -18,7 +18,7 @@ import sexpr
const ARRAY_TYPE = $40
const MARK_BIT = $80
const MARK_MASK = $7F
const NULL_HACK = 1 // Hack so we can set elements to NULL
const NULL_HACK = 1 // Hack so we can set APVALs to NULL
struc t_elem
word link
@ -65,7 +65,7 @@ var prog, prog_expr, prog_return // Current PROG expressions
var sym_cond, sym_if, sym_fpint, sym_fpfrac
var pred_true
res[t_except] break_repl // Breeak out of eval processing
res[t_except] break_repl // Breeak out of eval processing
const csw = $0036 // Output switch vector
var scrncsw = 0 // Output screen value
@ -179,6 +179,10 @@ def natv_gc(symptr, expr)
return new_int(heapavail, 0)
end
//
// Useful Apple II features
//
def natv_printer(symptr, expr)
byte slot
@ -197,6 +201,30 @@ def natv_printer(symptr, expr)
return new_int(slot, 0)
end
def natv_gr(symptr, expr)
if eval_expr(expr=>car)
conio:grmode(TRUE) // Mixed mode
else
conio:textmode(40) // 40 column text
fin
return expr
end
def natv_color(symptr, expr)
conio:grcolor(eval_int(expr)=>intval & $0F)
return expr
end
def natv_plot(symptr, expr)
byte x, y
x = eval_int(expr)=>intval
y = eval_int(expr=>cdr)=>intval
conio:grplot(x, y)
return expr
end
def natv_bye(symptr, expr)
quit = TRUE
return new_sym("GOODBYE!")
@ -319,6 +347,9 @@ new_sym("SET")=>natv = @natv_set
new_sym("SETQ")=>natv = @natv_setq
new_sym("GC")=>natv = @natv_gc
new_sym("PRINTER")=>natv = @natv_printer
new_sym("GR")=>natv = @natv_gr
new_sym("COLOR")=>natv = @natv_color
new_sym("PLOT")=>natv = @natv_plot
new_sym("QUIT")=>natv = @natv_bye
parse_cmdline

24
src/lisp/lores.lisp Normal file
View File

@ -0,0 +1,24 @@
(DEFINE
(PLOTFUNC (LAMBDA (FN)
(PROG (X Y)
(SETQ X 0)
A (SETQ Y (* 0.99 (FN (/ (- X 20) 20.0))))
(IF (AND (> Y -1.0) (< Y 1.0))
(PLOT X, (* (+ Y 1.0) 19.0)))
(SETQ X (+ X 1))
(IF (< X 40) (GO A))
(RETURN 0)
)
))
(PLOTSIN (LAMBDA ()
(PLOTFUNC '(LAMBDA (S) (SIN (* S PI))))
))
(PLOTCOS (LAMBDA ()
(PLOTFUNC '(LAMBDA (S) (COS (* S PI))))
))
)
(GR T)
(COLOR 2)
(PLOTSIN)
(COLOR 9)
(PLOTCOS)

128
src/lisp/s-expr.pla
View File

@ -15,7 +15,7 @@ const NUM_FLOAT = $32
const ARRAY_TYPE = $40
const MARK_BIT = $80
const MARK_MASK = $7F
const NULL_HACK = 1 // Hack so we can set elements to NULL
const NULL_HACK = 1 // Hack so we can set APVALs to NULL
struc t_elem
word link
@ -723,7 +723,7 @@ def eval_args(argvals)
sweep_stack[sweep_stack_top] = eval_expr(argvals=>car)
sweep_stack_top++
if sweep_stack_top >= SWEEPSTACK_MAX
puts("Arg val overflow\n")
puts("Arg overflow\n")
return NULL
fin
argvals = argvals=>cdr
@ -732,62 +732,64 @@ def eval_args(argvals)
return sweep_stack_top
end
def apply_args(curl, expr, argvals)#2 // curl, expr
var argsyms, arglist, pairlist, argbase
def build_args(argsyms, argbase)#0
var arglist, pairlist
arglist = NULL
while argsyms
//
// Build argument/value pairs
//
if arglist
pairlist=>cdr = new_cons
pairlist = pairlist=>cdr
else
arglist = new_cons
pairlist = arglist
fin
pairlist=>car = new_cons
pairlist=>car=>car = argsyms=>car
pairlist=>car=>cdr = sweep_stack[argbase]
argsyms = argsyms=>cdr
argbase++
loop
if arglist
pairlist=>cdr = assoc_list
assoc_list = arglist
fin
end
def copy_args(argsyms, argbase)#0
var arglist
arglist = assoc_list
while argsyms
arglist=>car=>cdr = sweep_stack[argbase]
arglist = arglist=>cdr
argsyms = argsyms=>cdr
argbase++
loop
end
def apply_args(curl, expr, argvals)#2 // curl, expr
if !expr or expr=>car <> sym_lambda
puts("Invalid LAMBDA expression: "); print_expr(expr); putln
puts("Bad LAMBDA: "); print_expr(expr); putln
return NULL, NULL
fin
argsyms = expr=>cdr=>car
argbase = eval_args(argvals)
if curl == expr
//
// Set associations
// Overwrite argument associations
//
arglist = assoc_list
while argsyms
arglist=>car=>cdr = sweep_stack[argbase]
arglist = arglist=>cdr
argsyms = argsyms=>cdr
argbase++
loop
if trace
puts("TAIL call:")
fin
copy_args(expr=>cdr=>car, eval_args(argvals))
else
//
// Build arg list before prepending to assoc_list
// Build argument association list
//
arglist = NULL
while argsyms
//
// Build argument/value pairs
//
if arglist
pairlist=>cdr = new_cons
pairlist = pairlist=>cdr
else
arglist = new_cons
pairlist = arglist
fin
pairlist=>car = new_cons
pairlist=>car=>car = argsyms=>car
pairlist=>car=>cdr = sweep_stack[argbase]
argsyms = argsyms=>cdr
argbase++
loop
if arglist
pairlist=>cdr = assoc_list
assoc_list = arglist
fin
if trace
puts("APPLY call:")
fin
build_args(expr=>cdr=>car, eval_args(argvals))
fin
if trace
print_expr(expr); putln
print_expr(assoc_list); putln
puts("\nTRACE:"); print_expr(expr)
puts("\n ASSOC:"); print_expr(assoc_list); putln
fin
return expr, expr=>cdr=>cdr=>car
end
@ -816,37 +818,17 @@ def eval_funarg(funarg, argvals)
//
arglist = NULL
argbase = eval_args(argvals)
argsyms = funexpr=>cdr=>car
while argsyms
//
// Build argument/value pairs
//
if arglist
pairlist=>cdr = new_cons
pairlist = pairlist=>cdr
else
arglist = new_cons
pairlist = arglist
fin
pairlist=>car = new_cons
pairlist=>car=>car = argsyms=>car
pairlist=>car=>cdr = sweep_stack[argbase]
argsyms = argsyms=>cdr
argbase++
loop
push_sweep_stack(assoc_list)
push_sweep_stack(assoc_list) // Save current association list
assoc_list = funarg=>cdr=>cdr=>car // Swap associcate list pointer
if arglist
pairlist=>cdr = assoc_list
assoc_list = arglist
fin
argsyms = funexpr=>cdr=>car
build_args(funexpr=>cdr=>car, argbase)
if trace
puts("FUNARG call:"); print_expr(funarg); putln
print_expr(assoc_list); putln
puts("\nFUNARG:"); print_expr(funarg)
puts("\n ASSOC:"); print_expr(assoc_list); putln
fin
funexpr = eval_expr(funexpr=>cdr=>cdr=>car)
funarg=>cdr=>cdr=>car = assoc_list // Save current environ
assoc_list = pop_sweep_stack
funarg=>cdr=>cdr=>car = assoc_list // Save updated FUNARG associations
assoc_list = pop_sweep_stack // Restore association list
return funexpr
end

39
src/lisp/s-math.pla
View File

@ -16,6 +16,7 @@ import sexpr
const ARRAY_TYPE = $40
const MARK_BIT = $80
const MARK_MASK = $7F
const NULL_HACK = 1 // Hack so we can set APVALs to NULL
struc t_elem
word link
@ -53,6 +54,8 @@ end
res[t_numint] nan = 0, 0, NUM_INT, 0, 0, 0, 128 // NaN
res[10] tempext
def eval_num(expr)
var result
@ -115,6 +118,11 @@ def push_num(numptr)#0
fin
end
def natv_numberp(symptr, expr)
expr = eval_expr(expr)
return bool_pred(expr and (expr->type & TYPE_MASK == NUM_TYPE))
end
def natv_sum(symptr, expr)
var num
var[2] intsum
@ -439,22 +447,6 @@ def natv_max(symptr, expr)
return new_float(@extmax)
end
def natv_pi(symptr, expr)
var[5] ext
fpu:constPi()
fpu:pullExt(@ext)
return new_float(@ext)
end
def natv_e(symptr, expr)
var[5] ext
fpu:constE()
fpu:pullExt(@ext)
return new_float(@ext)
end
def natv_logb(symptr, expr)
var[5] ext
@ -784,9 +776,19 @@ def natv_rotate(symptr, expr)
end
//
// Install math functions
// Install numerical constants and functions
//
fpu:reset()
fpu:constPi()
fpu:pullExt(@tempext)
new_sym("PI")=>apval = new_float(@tempext) ^ NULL_HACK
fpu:constE()
fpu:pullExt(@tempext)
new_sym("MATH_E")=>apval = new_float(@tempext) ^ NULL_HACK
fpu:sinX() // Force load of ELEMS library
new_sym("NUMBERP")=>natv = @natv_numberp
new_sym("SUM")=>natv = @natv_sum
new_sym("+")=>natv = @natv_sum
new_sym("-")=>natv = @natv_sub
@ -799,8 +801,6 @@ new_sym(">")=>natv = @natv_gt
new_sym("<")=>natv = @natv_lt
new_sym("MIN")=>natv = @natv_min
new_sym("MAX")=>natv = @natv_max
new_sym("PI")=>natv = @natv_pi
new_sym("MATH_E")=>natv = @natv_e
new_sym("LOGB")=>natv = @natv_logb
new_sym("SCALEB_I")=>natv = @natv_scalebI
new_sym("TRUNCATE")=>natv = @natv_trunc
@ -829,6 +829,5 @@ new_sym("BITOR")=>natv = @natv_bitor
new_sym("BITXOR")=>natv = @natv_bitxor
new_sym("SHIFT")=>natv = @natv_shift
new_sym("ROTATE")=>natv = @natv_rotate
fpu:reset()
return modkeep | modinitkeep
done

1
src/mklisp
View File

@ -33,3 +33,4 @@ cat lisp/fact.lisp | ./ac.jar -ptx DRAWL.po lisp/FACT.LISP TXT
cat lisp/loop.lisp | ./ac.jar -ptx DRAWL.po lisp/LOOP.LISP TXT
cat lisp/minmax.lisp | ./ac.jar -ptx DRAWL.po lisp/MINMAX.LISP TXT
cat lisp/prog.lisp | ./ac.jar -ptx DRAWL.po lisp/PROG.LISP TXT
cat lisp/lores.lisp | ./ac.jar -ptx DRAWL.po lisp/LORES.LISP TXT

1
src/mkrel
View File

@ -188,6 +188,7 @@ cp lisp/fact.lisp prodos/bld/lisp/FACT.LISP.TXT
cp lisp/loop.lisp prodos/bld/lisp/LOOP.LISP.TXT
cp lisp/minmax.lisp prodos/bld/lisp/MINMAX.LISP.TXT
cp lisp/prog.lisp prodos/bld/lisp/PROG.LISP.TXT
cp lisp/lores.lisp prodos/bld/lisp/LORES.LISP.TXT
#mkdir prodos/bld/examples
#cp samplesrc/examples/ex.1.pla prodos/bld/examples/EX.1.PLA.TXT