REBOL [
Title: "Graph a function"
Date: 19-Jun-2001/17:58
Version: 1.0.2
File: %Graph.r
Author: "Phil Bevan"
Purpose: {Graph a function
draw-line function adapted from drawline.r by Larry Palmiter
rounding function by Ladislav Mecir
Changes since 1.0.0
round value of x & fx before converting to pair
minor gui additions - load & save equations
change initial screen limits
Usage ....
Type in your function of x into the input field
Some pretty functions to get you started .....
3 * sin (0.5 * pi * x)
3 * sin (x * x)
exp(0.1 * x) * (sin(4 * pi * x))
4 * sin (4 * pi / x)
0.2 * exp(- x) * sin (0.5 * pi * x)
10 / ((3 * x * x) + (4 * x) - 3)
}
Email: philb@upnaway.com
Category: [math]
]
; functions
paper: make object!
[
size: 0x0
x-min: -1
x-max: 1
y-min: -1
y-max: 1
grid: yes
x-grid: 20
y-grid: 20
grid-color: red
axes: yes
axes-color: black
paper-color: white
pen-color: black
axes-color: black
image: none
crt: func
[
size [pair!]
xmin [decimal!]
xmax [decimal!]
ymin [decimal!]
ymax [decimal!]
]
[
self/size: size
self/x-min: xmin
self/x-max: xmax
self/y-min: ymin
self/y-max: ymax
self/image: to-image to-pair reduce [size/x size/y]
clear-im self/image self/paper-color
]
]
; clear the image to a colour
clear-im: func [im [image!] color [tuple!] /local j]
[
repeat j im/size/x * im/size/y [poke im j color]
]
; plot a point
plot: func [im [image!] p col [tuple!] /local i xs ys]
[
set [xs ys] [im/size/x im/size/y]
if any[p/x < 1 p/x > xs p/y < 1 p/y > ys]
[return]
i: ys - p/y * xs + p/x
if any [i <= 0 i > (im/size/x * im/size/y)]
[return]
poke im i col
]
draw-line: func [
{draw line from point a to b using Bresenham's algorithm}
im [image!]
a [pair!]
b [pair!]
color [tuple!]
/local d inc dpr dpru p set-pixel xs ys
][
set [xs ys] [im/size/x im/size/y]
set-pixel: func [p c] [poke im (ys - p/y * xs + p/x) c]
if any [a/x < 1 a/y < 1 a/x > xs a/y > ys b/x < 1 b/y < 1 b/x > xs b/y > ys] [return]
d: abs (b - a)
inc: 1x1
if a/x > b/x [inc/x: -1]
if a/y > b/y [inc/y: -1]
either d/x >= d/y [
dpr: 2 * d/y
dpru: dpr - (2 * d/x)
p: dpr - d/x
loop d/x + 1 [
set-pixel a color
either p > 0 [
a: a + inc
p: p + dpru
][
a/x: a/x + inc/x
p: p + dpr
]
]
][
dpr: 2 * d/x
dpru: dpr - (2 * d/y)
p: dpr - d/y
loop d/y + 1 [
set-pixel a color
either p > 0 [
a: a + inc
p: p + dpru
][
a/y: a/y + inc/y
p: p + dpr
]
]
]
]
; Convert Degrees to Radians & Radians to Degrees
rad: function [x] [] [ x * pi / 180 ]
deg: function [x] [] [ x * 180 / pi ]
; trig functions
sin: function [x] [] [return sine/radians x]
cos: function [x] [] [return cosine/radians x]
tan: function [x] [] [return tangent/radians x]
; square-root
sqrt: function [x] [] [return square-root x]
; hyperbolic trig functions
sinh: function [x] [] [return ((exp(x)) - (exp(- x))) / 2]
cosh: function [x] [] [return ((exp(x)) + (exp(- x))) / 2]
tanh: function [x] [] [return ((exp(2 * x)) - 1) / ((exp(2 * x)) + 1)]
fac: func [x [integer!] /local fa i]
[
if x < 0 [return none]
fa: 1.0
i: 1
while [i <= x]
[
fa: fa * i
i: i + 1
]
return fa
]
; create a function
create-function: function [t-func [string!]] [f]
[
; return a newly created function
if error? try [f: to-block load t-func]
[return none]
function [x [any-type!]] [] f
]
mod: func
[
{compute a non-negative remainder}
a [number!]
b [number!]
/local r
]
[
either negative? r: a // b [
r + abs b
] [r]
]
round: func
[
"Round a number"
n [number!]
/places
p [integer!] {Decimal places - can be negative}
/local factor r
]
[
factor: either places [10 ** (- p)] [1]
n: 0.5 * factor + n
n - mod n factor
]
floor: func [
n [number!]
/places
p [integer!] {Decimal places - can be negative}
/local factor r
] [
factor: either places [10 ** (- p)] [1]
n - mod n factor
]
ceiling: func [
n [number!]
/places
p [integer!] {Decimal places - can be negative}
/local factor r
] [
factor: either places [10 ** (- p)] [1]
n + mod (- n) factor
]
truncate: func [
n [number!]
/places
p [integer!] {Decimal places - can be negative}
/local factor r
] [
factor: either places [10 ** (- p)] [1]
n - (n // factor)
]
; initialise the graph
init-graph: func [paper [object!]]
[
clear-im paper/image paper/paper-color
draw-axes paper
]
draw-axes: func [paper /local pt]
[
pt: coordinates paper 0 0
if all [pt/y >= 0 pt/y < paper/size/y]
[draw-line paper/image to-pair reduce [1 pt/y] to-pair reduce [(paper/size/x - 1) pt/y] paper/axes-color] ; x-axis
if all [pt/x >= 0 pt/x < paper/size/x]
[draw-line paper/image to-pair reduce [pt/x 1] to-pair reduce [pt/x paper/size/y] paper/axes-color]; y-axis
]
; convert to co-ordinates
coordinates: func [paper [object!] x [number!] y [number!] /local xc yc]
[
xd: x - paper/x-min
xp: (paper/x-max - paper/x-min) / paper/size/x
xc: xd / xp
if any [xc < 0 xc > paper/size/x] [-1]
if error? try[xc: to-integer round xc]
[return none]
yd: y - paper/y-min
yp: (paper/y-max - paper/y-min) / paper/size/y
yc: yd / yp
if any [yc < 0 yc > paper/size/y] [-1]
if error? try[yc: to-integer round yc]
[return none]
return make pair! reduce [xc yc]
]
new-styles: stylize
[
fix-area: area font [name: "courier new" size: 12] wrap
fix-field: field font [name: "courier new" size: 12]
fix-text: text font [name: "courier new" size: 12]
]
; Draw the graph
draw-graph: func [paper [object!] t-fx [string!] trace [string!] /local x x-step fx pt last-pt]
[
if t-fx = ""
[request/ok "No function entered" return]
f-fx: create-function t-fx
if not function? :f-fx
[request/ok "Improper function entered" return]
last-pt: none
x-step: (paper/x-max - paper/x-min) / paper/size/x
for x paper/x-min paper/x-max x-step
[
either not error? try [fx: f-fx x]
[
pt: coordinates paper x fx
if pt <> none
[
switch trace
[
"Point"
[plot paper/image pt paper/pen-color]
"Line"
[
either last-pt <> none
[draw-line paper/image last-pt pt paper/pen-color]
[plot paper/image pt paper/pen-color]
]
]
]
last-pt: pt
]
[last-pt: none]
]
]
; Graph Paper settings
gr-settings: func
[
paper [object!]
gr-face [object!]
/local prefs f-xmin f-xmax f-ymin f-ymax f-paper-color f-pen-color lv-valid
]
[
prefs: view/new layout
[
backdrop 0.150.0
styles new-styles
origin 10x10
below
at 10x10
vtext "Min X" 60x24
vtext "Max X" 60x24
vtext "Min Y" 60x24
vtext "Max Y" 60x24
vtext "Paper Color" 80x24
vtext "Pen Color" 80x24
vtext "Clear" 80x24
return
f-xmin: fix-field to-string(paper/x-min)
f-xmax: fix-field to-string(paper/x-max)
f-ymin: fix-field to-string(paper/y-min)
f-ymax: fix-field to-string(paper/y-max)
f-paper-color: fix-field to-string(paper/paper-color)
f-pen-color: fix-field to-string(paper/pen-color)
cb-clear: check with [state: false]
button "Apply"
[
lv-valid: yes
if error? try [paper/x-min: to-decimal f-xmin/text] [request/ok "Invalid Min X value entered" lv-valid: no]
if error? try [paper/x-max: to-decimal f-xmax/text] [request/ok "Invalid Max X value entered" lv-valid: no]
if error? try [paper/y-min: to-decimal f-ymin/text] [request/ok "Invalid Min Y value entered" lv-valid: no]
if error? try [paper/y-max: to-decimal f-ymax/text] [request/ok "Invalid Min Y value entered" lv-valid: no]
if error? try [paper/paper-color: to-tuple f-paper-color/text] [request/ok "Invalid Paper Color entered" lv-valid: no]
if error? try [paper/pen-color: to-tuple f-pen-color/text] [request/ok "Invalid Pen Color entered" lv-valid: no]
if cb-clear/data = true
[
init-graph paper
show gr-face
]
if lv-valid = yes
[unview prefs]
]
]
]
;
; Main Line
;
gr-size: 500x500
gr-paper: make paper []
gr-paper/crt gr-size -5.0 5.0 -5.0 5.0
gr-paper/pen-color: 0.0.255
draw-axes gr-paper
;
; view the window
;
view layout [
backdrop 0.150.0
origin 5x5
styles new-styles
below
at 5x5
gr-paper-f: image gr-paper/image
across
t-func1: fix-field (gr-size * 1x0 + 0x24)
return
r-trace: choice 120.20.120 100x24 data ["Line" "Point"]
button "Graph Color"
[
gr-col: request-color/color gr-paper/pen-color
if gr-col <> none
[gr-paper/pen-color: gr-col]
]
button "Draw f(x)" 100x24
[
draw-graph gr-paper t-func1/text first r-trace/data
show gr-paper-f
]
button "Save Image"
[
t-save-name: request-file/title/filter/keep/file "Save Graph as png" "Save" "*.png" "graph.png"
if t-save-name <> none
[
if error? try [save/png to-file t-save-name gr-paper/image]
[request/OK "Unable to Save graph"]
]
]
return
button "Settings" 100x24
[gr-settings gr-paper gr-paper-f]
button "Clear Paper" 100x24
[
init-graph gr-paper
show gr-paper-f
]
button "Save Equation"
[
either t-func1/text = ""
[request/ok "No equation to Save"]
[
filnm: request-file/title/filter/file/keep "Save Equation" "Save" "*.eqn" "graph.eqn"
if filnm <> none
[
if error? try [write to-file filnm t-func1/text]
[request/OK "Unable to Save Equation"]
]
]
]
button "Load Equation"
[
filnm: request-file/title/filter/file/keep "Load Equation" "Load" "*.eqn" "graph.eqn"
if filnm <> none
[
t-func1/text: read to-file filnm
show t-func1
]
]
]