# @dapp-format 1
# @id plot
# @name Plot
# @version 1.0.1
# @boards fnk0104
# @runtime >=1.4.2 <2.0.0
# @echo off
# @summary Graph a typed formula of x, with pan, zoom and auto-fit
# /apps/plot.dapp
# Type a formula in x -- sin(x/8)*10, x^2-3, sqrt(x)*2 -- and it is graphed
# across the canvas. Left/right pan, up/down zoom, r resets the view, f
# types a new formula, escape quits.
#
# EXPR cannot help here: its expression text is fixed at parse time, with
# only $variables filled in dynamically, so a formula the user types at
# runtime cannot be handed to it directly -- that is the whole reason
# `sheet.dapp` carries its own shunting-yard evaluator instead of
# delegating to EXPR, and this app reuses that same evaluator (extended
# with a variable `x` and one-argument functions in place of cell ranges).
#
# What EXPR *can* do is compute a transcendental function of an
# already-known number, since that number arrives through ordinary $
# substitution. So while the shunting-yard's own arithmetic (+ - * / % ^)
# is hand-rolled the way sheet.dapp's is, every sin/cos/tan/sqrt/exp/ln
# call is one line delegating straight to EXPR: "EXPR res sin($a/1000)*
# 1000". That is also why the fixed point scale is 1000 and not 1: .dapp
# variables are integers, and every EXPR result is rounded to one the
# moment it is stored, so a graph working in whole units would lose all
# the fractional structure between one operator and the next. Scaling
# every operand by 1000 first buys three fractional digits through the
# whole evaluation, at the cost of one rounding per operator -- the same
# cost a real floating-point evaluator pays per operator, just spelled out.

CANVAS 78 27
SET gw 76
SET gh 18
DIM nstk 32
DIM ostk 32
DIM ys 76
DIM okarr 76

COLOR yellow
PUT 18 3 "P L O T"
COLOR white
PUT 10 6 "type a formula of x: sin(x/8)*10, x^2-3, sqrt(x)*2"
PUT 10 7 "+ - * / % ^, parens, and sin cos tan sqrt abs floor ceil exp ln"
COLOR cyan
PUT 10 9 "left/right pan   up/down zoom   r resets   f new formula   esc quits"
FLIP
WAIT 1600

SETSTR formula "sin(x/8)*10"
SET xscale 100
SET xoffset 0
SET quit 0
GOSUB compute
GOSUB draw

:loop
KEY k
IF $k = 0 GOTO lp_wait
IF $k = $kesc GOTO leave
IF $k = 102 GOTO hk_formula
IF $k = 70 GOTO hk_formula
IF $k = 114 GOTO hk_reset
IF $k = 82 GOTO hk_reset
IF $k = $kleft GOTO hk_left
IF $k = 97 GOTO hk_left
IF $k = $kright GOTO hk_right
IF $k = 100 GOTO hk_right
IF $k = $kup GOTO hk_zoomin
IF $k = 119 GOTO hk_zoomin
IF $k = $kdown GOTO hk_zoomout
IF $k = 115 GOTO hk_zoomout
GOTO lp_wait

:hk_left
EXPR xoffset $xoffset - $xscale * $gw / 4
GOTO hk_redraw
:hk_right
EXPR xoffset $xoffset + $xscale * $gw / 4
GOTO hk_redraw
:hk_zoomin
EXPR xscale $xscale * 2 / 3
IF $xscale >= 1 GOTO hk_redraw
SET xscale 1
GOTO hk_redraw
:hk_zoomout
EXPR xscale $xscale * 3 / 2
GOTO hk_redraw
:hk_reset
SET xscale 100
SET xoffset 0
:hk_redraw
GOSUB compute
GOSUB draw
GOTO lp_wait

:hk_formula
ENDCANVAS
COLOR white
INPUT newformula "f(x)= "
LEN nl $newformula
IF $nl = 0 GOTO hk_formend
SETSTR formula $newformula
:hk_formend
CANVAS 78 27
GOSUB compute
GOSUB draw

:lp_wait
WAIT 16
GOTO loop

# ---------------------------------------------------------------- sampling

# fills ys[]/okarr[] for every visible column and tracks the y-range, so
# the draw pass never has to re-evaluate the formula
:compute
SET haveany 0
SET sx 0
:cp_col
EXPR curx $xoffset + ($sx - $gw / 2) * $xscale
SETSTR f $formula
GOSUB evalf
SET okarr[$sx] 0
IF $perr = 1 GOTO cp_next
SET v $pres
IF $v > 2000000 GOTO cp_clamphigh
IF $v < -2000000 GOTO cp_clamplow
GOTO cp_use
:cp_clamphigh
SET v 2000000
GOTO cp_use
:cp_clamplow
SET v -2000000
:cp_use
SET ys[$sx] $v
SET okarr[$sx] 1
IF $haveany = 1 GOTO cp_widen
SET ymin $v
SET ymax $v
SET haveany 1
GOTO cp_next
:cp_widen
IF $v < $ymin GOSUB cp_setmin
IF $v > $ymax GOSUB cp_setmax
:cp_next
ADD sx 1
IF $sx < $gw GOTO cp_col

SET badrange 0
IF $haveany = 0 GOTO cp_norange
EXPR span $ymax - $ymin
IF $span > 0 GOTO cp_done
:cp_norange
SET badrange 1
EXPR ymin $ymin - 1000
EXPR ymax $ymax + 1000
IF $haveany = 1 GOTO cp_done
SET ymin -1000
SET ymax 1000
:cp_done
RETURN

:cp_setmin
SET ymin $v
RETURN
:cp_setmax
SET ymax $v
RETURN

# in: v (a y value already in ys[]) -- out: rowfor, the screen row for it,
# clamped so a clipped/asymptotic value still draws at the frame's edge
:rowfor
EXPR span $ymax - $ymin
EXPR ghm1 $gh - 1
EXPR rowfor $ghm1 - ($v - $ymin) * $ghm1 / $span
IF $rowfor < 0 GOTO rf_low
IF $rowfor > $ghm1 GOTO rf_high
RETURN
:rf_low
SET rowfor 0
RETURN
:rf_high
SET rowfor $ghm1
RETURN

# ---------------------------------------------------------------- drawing

:draw
CLS
COLOR pink
PUT 0 0 "PLOT"
COLOR white
PUT 6 0 $formula

SET gy0 2
GOSUB axes
GOSUB curve

COLOR cyan
PUT 0 21 "y"
COLOR white
PUT 2 21 $ymax
COLOR cyan
PUT 8 21 ".."
COLOR white
PUT 11 21 $ymin
COLOR cyan
PUT 0 22 "x"
GOSUB leftx
COLOR white
PUT 2 22 $lx
COLOR cyan
PUT 12 22 ".."
GOSUB rightx
COLOR white
PUT 15 22 $rx
COLOR cyan
PUT 0 23 "scale"
COLOR white
PUT 6 23 $xscale
IF $badrange = 0 GOTO dr_keys
COLOR yellow
PUT 20 23 "(flat or all-error - padded range shown)"

:dr_keys
COLOR yellow
PUT 0 25 "left/right pan   up/down zoom   r reset   f formula   esc quit"
FLIP
RETURN

# a faint cross for x=0/y=0 when they fall inside the visible window,
# drawn before the curve so the curve visibly crosses it
:axes
IF $haveany = 0 GOTO ax_done
IF $ymin > 0 GOTO ax_skiphoriz
IF $ymax < 0 GOTO ax_skiphoriz
SET v 0
GOSUB rowfor
EXPR hy $gy0 + $rowfor
COLOR blue
SET hx 0
:ax_hline
PUT $hx $hy "-"
ADD hx 1
IF $hx < $gw GOTO ax_hline
:ax_skiphoriz

EXPR left $xoffset - ($gw / 2) * $xscale
EXPR right $xoffset + ($gw / 2) * $xscale
IF $left > 0 GOTO ax_skipvert
IF $right < 0 GOTO ax_skipvert
EXPR vx $gw / 2 - $xoffset / $xscale
IF $vx < 0 GOTO ax_skipvert
IF $vx >= $gw GOTO ax_skipvert
COLOR blue
SET vy $gy0
EXPR vybottom $gy0 + $gh
:ax_vline
PUT $vx $vy "|"
ADD vy 1
IF $vy < $vybottom GOTO ax_vline
:ax_skipvert
:ax_done
RETURN

:curve
SET sx 0
:cv_col
IF $okarr[$sx] = 0 GOTO cv_next
SET v $ys[$sx]
GOSUB rowfor
EXPR cy $gy0 + $rowfor
COLOR green
PUT $sx $cy "*"
:cv_next
ADD sx 1
IF $sx < $gw GOTO cv_col
RETURN

# ---------------------------------------------------------------- axis text

:leftx
EXPR lxr $xoffset - ($gw / 2) * $xscale
GOSUB scaletext
SETSTR lx $st
RETURN

:rightx
EXPR lxr $xoffset + ($gw / 2) * $xscale
GOSUB scaletext
SETSTR rx $st
RETURN

# in: lxr (a fixed-point*1000 value) -- out: st, printed with 3 decimals
:scaletext
SETSTR st ""
SET neg 0
IF $lxr >= 0 GOTO sc_abs
SET neg 1
EXPR lxr 0 - $lxr
:sc_abs
EXPR whole floor($lxr / 1000)
EXPR frac $lxr - $whole * 1000
IF $neg = 0 GOTO sc_whole
APPEND st "-"
:sc_whole
APPEND st $whole
APPEND st "."
IF $frac >= 100 GOTO sc_frac
APPEND st "0"
IF $frac >= 10 GOTO sc_frac
APPEND st "0"
:sc_frac
APPEND st $frac
RETURN

# ---------------------------------------------------------------- evaluator
# (validated separately -- see the module note at the top of the file)

:evalf
SET perr 0
SET pres 0
SET nsp 0
SET osp 0
SET pi 0
SET expect 1
LEN plen $f

:ev_next
IF $pi >= $plen GOTO ev_end
CHARAT pc $f $pi
IF $pc = 32 GOTO ev_space
IF $expect = 0 GOTO ev_op

IF $pc = 40 GOTO ev_lparen
IF $pc = 45 GOTO ev_neg
IF $pc = 43 GOTO ev_space
IF $pc < 48 GOTO ev_alpha
IF $pc <= 57 GOTO ev_number
:ev_alpha
GOSUB upperc
IF $pc < 65 GOTO ev_bad
IF $pc > 90 GOTO ev_bad
GOTO ev_name

:ev_space
ADD pi 1
GOTO ev_next

:ev_lparen
SET op 8
GOSUB pushop
ADD pi 1
GOTO ev_next

:ev_neg
SET op 7
GOSUB pushop
ADD pi 1
GOTO ev_next

:ev_number
SET intpart 0
:ev_digit
CHARAT pc $f $pi
IF $pc < 48 GOTO ev_numdone1
IF $pc > 57 GOTO ev_numdone1
SUB pc 48
MUL intpart 10
ADD intpart pc
ADD pi 1
IF $pi < $plen GOTO ev_digit
:ev_numdone1
SET fracpart 0
SET fracdigits 0
IF $pi >= $plen GOTO ev_numcombine
CHARAT pc $f $pi
IF $pc <> 46 GOTO ev_numcombine
ADD pi 1
:ev_fracdigit
IF $fracdigits >= 3 GOTO ev_fracskip
IF $pi >= $plen GOTO ev_numcombine
CHARAT pc $f $pi
IF $pc < 48 GOTO ev_numcombine
IF $pc > 57 GOTO ev_numcombine
SUB pc 48
MUL fracpart 10
ADD fracpart pc
ADD fracdigits 1
ADD pi 1
GOTO ev_fracdigit
:ev_fracskip
IF $pi >= $plen GOTO ev_numcombine
CHARAT pc $f $pi
IF $pc < 48 GOTO ev_numcombine
IF $pc > 57 GOTO ev_numcombine
ADD pi 1
GOTO ev_fracskip
:ev_numcombine
SET padmul 1
IF $fracdigits = 1 GOTO ev_padmul100
IF $fracdigits = 2 GOTO ev_padmul10
GOTO ev_paddone
:ev_padmul100
SET padmul 100
GOTO ev_paddone
:ev_padmul10
SET padmul 10
:ev_paddone
MUL fracpart $padmul
EXPR pval $intpart * 1000 + $fracpart
GOSUB pushnum
SET expect 0
GOTO ev_next

:ev_name
SETSTR ident ""
:ev_nch
IF $pi >= $plen GOTO ev_named
CHARAT pc $f $pi
GOSUB upperc
IF $pc < 65 GOTO ev_named
IF $pc > 90 GOTO ev_named
CHR one $pc
APPEND ident $one
ADD pi 1
GOTO ev_nch
:ev_named
IFEQ $ident "X" GOTO ev_pushx
IF $pi >= $plen GOTO ev_bad
CHARAT pc $f $pi
IF $pc <> 40 GOTO ev_bad
ADD pi 1
IFEQ $ident "SIN" GOTO ev_setfn9
IFEQ $ident "COS" GOTO ev_setfn10
IFEQ $ident "TAN" GOTO ev_setfn11
IFEQ $ident "SQRT" GOTO ev_setfn12
IFEQ $ident "ABS" GOTO ev_setfn13
IFEQ $ident "FLOOR" GOTO ev_setfn14
IFEQ $ident "CEIL" GOTO ev_setfn15
IFEQ $ident "EXP" GOTO ev_setfn16
IFEQ $ident "LN" GOTO ev_setfn17
GOTO ev_bad
:ev_setfn9
SET op 9
GOTO ev_pushfn
:ev_setfn10
SET op 10
GOTO ev_pushfn
:ev_setfn11
SET op 11
GOTO ev_pushfn
:ev_setfn12
SET op 12
GOTO ev_pushfn
:ev_setfn13
SET op 13
GOTO ev_pushfn
:ev_setfn14
SET op 14
GOTO ev_pushfn
:ev_setfn15
SET op 15
GOTO ev_pushfn
:ev_setfn16
SET op 16
GOTO ev_pushfn
:ev_setfn17
SET op 17
:ev_pushfn
GOSUB pushop
SET expect 1
GOTO ev_next

:ev_pushx
SET pval $curx
GOSUB pushnum
SET expect 0
GOTO ev_next

:ev_op
IF $pc = 41 GOTO ev_rparen
SET op 0
IF $pc = 43 GOTO ev_add
IF $pc = 45 GOTO ev_sub
IF $pc = 42 GOTO ev_mul
IF $pc = 47 GOTO ev_div
IF $pc = 37 GOTO ev_mod
IF $pc = 94 GOTO ev_pow
GOTO ev_bad
:ev_add
SET op 1
GOTO ev_push
:ev_sub
SET op 2
GOTO ev_push
:ev_mul
SET op 3
GOTO ev_push
:ev_div
SET op 4
GOTO ev_push
:ev_mod
SET op 5
GOTO ev_push
:ev_pow
SET op 6

:ev_push
SET pop $op
GOSUB precof
SET myprec $prec
:ev_pop
IF $osp = 0 GOTO ev_pushed
SUB osp 1
SET pop $ostk[$osp]
ADD osp 1
IF $pop = 8 GOTO ev_pushed
IF $pop >= 9 GOTO ev_pushed
GOSUB precof
IF $prec < $myprec GOTO ev_pushed
IF $prec > $myprec GOTO ev_apply
IF $op = 6 GOTO ev_pushed
:ev_apply
GOSUB apply
IF $perr = 1 GOTO ev_stop
GOTO ev_pop
:ev_pushed
GOSUB pushop
ADD pi 1
SET expect 1
GOTO ev_next

:ev_rparen
IF $osp = 0 GOTO ev_bad
SUB osp 1
SET pop $ostk[$osp]
ADD osp 1
IF $pop = 8 GOTO ev_rclose
IF $pop >= 9 GOTO ev_rfunc
GOSUB apply
IF $perr = 1 GOTO ev_stop
GOTO ev_rparen
:ev_rfunc
GOSUB applyfunc
IF $perr = 1 GOTO ev_stop
:ev_rclose
SUB osp 1
ADD pi 1
SET expect 0
GOTO ev_next

:ev_end
IF $expect = 1 GOTO ev_bad
:ev_flush
IF $osp = 0 GOTO ev_result
SUB osp 1
SET pop $ostk[$osp]
ADD osp 1
IF $pop = 8 GOTO ev_bad
IF $pop >= 9 GOTO ev_bad
GOSUB apply
IF $perr = 1 GOTO ev_stop
GOTO ev_flush
:ev_result
IF $nsp <> 1 GOTO ev_bad
SET pres $nstk[0]
RETURN
:ev_bad
SET perr 1
:ev_stop
SET pres 0
RETURN

:precof
SET prec 0
IF $pop = 8 GOTO pr_done
SET prec 1
IF $pop <= 2 GOTO pr_done
SET prec 2
IF $pop <= 5 GOTO pr_done
SET prec 3
IF $pop = 6 GOTO pr_done
SET prec 4
:pr_done
RETURN

:apply
IF $osp = 0 GOTO ap_bad
SUB osp 1
SET pop $ostk[$osp]
IF $pop = 7 GOTO ap_negate
IF $nsp < 2 GOTO ap_bad
SUB nsp 1
SET b $nstk[$nsp]
SUB nsp 1
SET a $nstk[$nsp]
IF $pop = 1 GOTO ap_add
IF $pop = 2 GOTO ap_sub
IF $pop = 3 GOTO ap_mul
IF $pop = 4 GOTO ap_div
IF $pop = 5 GOTO ap_mod
IF $pop = 6 GOTO ap_pow
GOTO ap_bad
:ap_add
EXPR res $a + $b
GOTO ap_push
:ap_sub
EXPR res $a - $b
GOTO ap_push
:ap_mul
EXPR res ($a * $b) / 1000
GOTO ap_push
:ap_div
IF $b = 0 GOTO ap_bad
EXPR res ($a * 1000) / $b
GOTO ap_push
:ap_mod
IF $b = 0 GOTO ap_bad
EXPR res $a % $b
GOTO ap_push
:ap_pow
EXPR res pow($a / 1000, $b / 1000) * 1000
GOTO ap_push
:ap_negate
IF $nsp < 1 GOTO ap_bad
SUB nsp 1
EXPR res 0 - $nstk[$nsp]
:ap_push
SET nstk[$nsp] $res
ADD nsp 1
RETURN
:ap_bad
SET perr 1
RETURN

:applyfunc
IF $nsp < 1 GOTO af_bad
SUB nsp 1
SET a $nstk[$nsp]
IF $pop = 9 GOTO af_sin
IF $pop = 10 GOTO af_cos
IF $pop = 11 GOTO af_tan
IF $pop = 12 GOTO af_sqrt
IF $pop = 13 GOTO af_abs
IF $pop = 14 GOTO af_floor
IF $pop = 15 GOTO af_ceil
IF $pop = 16 GOTO af_exp
IF $pop = 17 GOTO af_ln
GOTO af_bad
:af_sin
EXPR res sin($a / 1000) * 1000
GOTO af_push
:af_cos
EXPR res cos($a / 1000) * 1000
GOTO af_push
:af_tan
EXPR res tan($a / 1000) * 1000
GOTO af_push
:af_sqrt
IF $a < 0 GOTO af_bad
EXPR res sqrt($a / 1000) * 1000
GOTO af_push
:af_abs
EXPR res abs($a)
GOTO af_push
:af_floor
EXPR res floor($a / 1000) * 1000
GOTO af_push
:af_ceil
EXPR res ceil($a / 1000) * 1000
GOTO af_push
:af_exp
EXPR res exp($a / 1000) * 1000
GOTO af_push
:af_ln
IF $a <= 0 GOTO af_bad
EXPR res ln($a / 1000) * 1000
GOTO af_push
:af_push
SET nstk[$nsp] $res
ADD nsp 1
RETURN
:af_bad
SET perr 1
RETURN

:pushnum
IF $nsp >= 32 GOTO pn_over
SET nstk[$nsp] $pval
ADD nsp 1
RETURN
:pn_over
SET perr 1
RETURN

:pushop
IF $osp >= 32 GOTO po_over
SET ostk[$osp] $op
ADD osp 1
RETURN
:po_over
SET perr 1
RETURN

:upperc
IF $pc < 97 GOTO uc_done
IF $pc > 122 GOTO uc_done
SUB pc 32
:uc_done
RETURN

:leave
ENDCANVAS
COLOR pink
PRINT "plot: last formula was $formula"
EXIT