Monday 27 January 2014

Creating a 3D surface

The following script permits you to see a 3D surface giving a z=f(x,y) function:


Just enter youf function in the text area and press apply. You can set point of view and camera direction of view using the text field.


To Rotate the surface use the following keys:
  • [ & ] - rotate left/right
  • { & } - rotate forard/back
  • "<" & ">" - roll left/right

To move the surface use the following function keys:
  • F1: move the surface left
  • F2: move the surface right
  • F3: move the surface up
  • F4: move the surface down
  • F5: move the surface back
  • F6: move the surface forward

Here is the source code:
rebol [
    Title:   "3D-Surface Plot"
    Date:     06-August-2007
    File:     %surface.r
    Version: 1.0.0
    Email: phil.bevan@gmail.com
    Category: [demo]
    Purpose:
    {
        Draw a surface with 3-D Perspective and allow roation
    }
    License: {Copyright (c) <2007>, <Phil Bevan>
All rights reserved.
Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
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.
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 OWNER 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.}
    History: [0.0.1 - Initial Version - test purposes only ]
    Email: phil.bevan@gmail.com
]
objs: []
;
; reb-3d.r
;

screen: 0x0
sox: 500
soy: 300
screen/x: sox * 2
screen/y: soy * 2
pen-color: black
anti-alias: true
camera: [0 0 6 0 0 800 800] ; x y z a1 a2 xsc ysc

; draw order for all faces
draw-o: []
; draw block
draw-bl: []
fn-rot: func [obj [block!]][
    context [
; print "Rot"
; r1: now/time/precise
        c1: cosine obj/1/4
        c2: cosine obj/1/5
        c3: cosine obj/1/6
        s1: sine obj/1/4
        s2: sine obj/1/5
        s3: sine obj/1/6
; r2: now/time/precise

        clear obj/3
        clear obj/4
        obj/3: copy/deep obj/2
        ; calculate the perspective of the points after the roation & translation
        foreach point obj/3 [
            ; Roation about z axis
            x1: (point/1 * c1) - (point/2 * s1)
            y1: (point/1 * s1) + (point/2 * c1)
            z1: point/3
            ; Roation about y axis
            x2: (x1 * c2) + (point/3 * s2)
            y2: y1
            z2: - (x1 * s2) + (point/3 * c2)
            x3: x2 + obj/1/1
            y3: (y2 * c3) - (z2 * s3) + obj/1/2
            z3: (y2 * s3) + (z2 * c3) + obj/1/3
            poke point 1 (x3 + camera/1)
            poke point 2 (y3 + camera/2)
            poke point 3 (z3 + camera/3)
            x: point/1 / point/3 * camera/6
            y: point/2 / point/3 * camera/7
            append obj/4 to pair! reduce[(x + sox) (soy - y)]
        ]
; c: 0
; r3: now/time/precise

        foreach f obj/5 [
; c: c + 1
            p1: f/1/1
            p2: f/1/2
            p3: f/1/3
            d1: reduce [(obj/3/:p2/1 - obj/3/:p1/1) (obj/3/:p2/2 - obj/3/:p1/2) (obj/3/:p2/3 - obj/3/:p1/3)] ; dist^2 between p2 & p1
            d2: reduce [(obj/3/:p3/1 - obj/3/:p1/1) (obj/3/:p3/2 - obj/3/:p1/2) (obj/3/:p3/3 - obj/3/:p1/3)] ; dist^2 between p3 & p1
            poke f 4 (-2 * obj/3/:p1/3 - d1/3 - d2/3) ; 2 * z-dist from camera
            n1: (d1/2 * d2/3) - (d1/3 * d2/2) ; normal x
            n2: - (d1/1 * d2/3) + (d1/3 * d2/1) ; normal y
            n3: (d1/1 * d2/2) - (d1/2 * d2/1) ; normal z
            v: 0 > ((obj/3/:p1/1 * n1) + (obj/3/:p1/2 * n2) + (obj/3/:p1/3 * n3))
            poke f 2 v
        ]
; r4: now/time/precise

;print ["Rotation times" r2 - r1 r3 - r2 r4 - r3]

    ]
]
; if c = 1255 [probe f probe obj/3/:p1 probe obj/3/:p2 probe obj/3/:p3 print ["^/Distance^/" d1 "^/" d2 "^/Normal^/" n1 n2 n3 "^/" ((obj/3/:p1/1 * n1) + (obj/3/:p1/2 * n2) + (obj/3/:p1/3 * n3))]]

fn-show: func [][
    context [
    ; setup the faces to be shown
    pts: []
    clear draw-o
    foreach o objs [
        foreach f o/5 [
            if any [f/2 = true f/3/1 = 3 f/3/1 = 4 f/3/1 = 5][
                append draw-o f/4
                switch f/3/1 [
                    1 [append/only draw-o reduce ['image (pick bmps f/3/2) pick o/4 f/1/1 pick o/4 f/1/2 pick o/4 f/1/3 pick o/4 f/1/4]]
                    2 [
                        pts: copy reduce ['fill-pen (pick clrs f/3/2) 'polygon]
                        foreach coord f/1 [append pts pick o/4 coord]
                        append/only draw-o pts
                    ]
                    3 [
                        either f/2 [cl: pick clrs f/3/2][cl: pick clrs f/3/3]
                        pts: copy reduce ['fill-pen cl 'polygon]
                        foreach coord f/1 [append pts pick o/4 coord]
                        append/only draw-o pts
                    ]
                    4 [
                        pts: copy reduce ['pen 0.0.0 'line]
                        foreach coord f/1 [append pts pick o/4 coord]
                        append pts pick o/4 f/1/1
                        append/only draw-o pts
                    ]
                    5 [append/only draw-o reduce ['image (pick bmps f/3/2) pick o/4 f/1/1 pick o/4 f/1/2 pick o/4 f/1/3 pick o/4 f/1/4]]
                ]
            ]
        ]
    ]
    ; sort the faces
    sort/skip draw-o 2
    ; reset the draw-block
    clear draw-bl
    append draw-bl reduce ['pen pen-color]
    either anti-alias [append draw-bl reduce ['anti-alias 'on]][append draw-bl reduce ['anti-alias 'off]]
    ; create the draw block
    forskip draw-o 2 [append draw-bl draw-o/2]
    ; show the face
    show f-box
    ]
]
;
; surface-obj.r
;

fn-append-pt: func [x [number!] y [number!] z [number!] pts [block!] ][
    append/only pts reduce [x y z]
]
fn-append-fc: func [p1 [integer!] p2 [integer!] p3 [integer!] p4 [integer!] ip-col [integer!] /local fc col][
    either p4 = 0
        [fc: reduce [p1 p2 p3]]
        [fc: reduce [p1 p2 p3 p4]]
    col: reduce [2 ip-col]
    facet: reduce [fc false col 0]
    append/only facets facet
]
fn-gen-plane: func [ip-col-1 [tuple!] ip-col-2 [tuple!] x1 [number!] y1 [number!] x2 [number!] y2 [number!] nsx [integer!] nsy [integer!]][
    context [
        pts: []
        facets: []
        obj: []
        obj-col: []
        npx: nsx + 1
        npy: nsy + 1
        cols: reduce[ip-col-1 ip-col-2]
        ; points & face
        clear pts
        for i y1 y2 (y2 - y1) / nsy [
            for j x1 x2 (x2 - x1) / nsx [
                ; points
                fn-append-pt i j 0 pts
            ]
        ]
        for i (y1 + ((y2 - y1) / nsy / 2)) (y2) (y2 - y1) / nsy [
            for j (x1 + ((x2 - x1) / nsx / 2))   (x2) (x2 - x1) / nsx [
                ; points
                fn-append-pt i j 0 pts
            ]
        ]
        ; faces
; print ["AAA" npx npy]
        clear facets
        for i 1 npy - 1 1 [
            for j 1 npx - 1 1 [
                ; top facets
                fc: reduce [
                    (npx * npy) + ((i - 1) * (npx - 1)) + j
                    (i - 1) * npx + j + 1
                    (i - 1) * npx + j
                ]
                facet: reduce [fc false copy [3 1 4] 0]
                append/only facets facet
                fc: reduce [
                    (npx * npy) + ((i - 1) * (npx - 1)) + j
                    (i - 1) * npx + j
                    i * npx + j
                ]
                facet: reduce [fc false copy [3 2 3] 0]
                append/only facets facet
                fc: reduce [
                    (npx * npy) + ((i - 1) * (npx - 1)) + j
                    i * npx + j
                    i * npx + j + 1
                ]
                facet: reduce [fc false copy [3 1 4] 0]
                append/only facets facet
                fc: reduce [
                    (npx * npy) + ((i - 1) * (npx - 1)) + j
                    i * npx + j + 1
                    (i - 1) * npx + j + 1
                ]
                facet: reduce [fc false copy [3 2 3] 0]
                append/only facets facet
            ]
        ]
        ; print length? facets

        ; create the object
        append obj reduce [
            ; angles & co-ordinates
            [0 0 0 0 0 0] ;obj/1
            pts
            []
            []
            facets
            cols
        ]
        append/only objs obj
    ]
]
;
; Main line
;

clrs: reduce [white orange red white 255.255.200 50.50.200 100.100.150 255.25.10 blue green yellow]
; foreach o objs [fn-rot o]

fn-show-cam: func [][
    f-cx/text: to string! camera/1
    f-cy/text: to string! camera/2
    f-cz/text: to string! camera/3
    if f-panel/show? [show [f-cx f-cy f-cz]]
]
fn-show-angles: func [][
    f-cx/text: to string! camera/1
    f-cy/text: to string! camera/2
    f-cz/text: to string! camera/3
]
help-text: {
Welcome to Surface.r.
To Rotate the surface use the following keys:
"[" & "]" - rotate left/right
"{" & "}" - rotate forard/back
"<" & ">" - roll left/right
To move the surface use the following function keys:
F1: move the surface left
F2: move the surface right
F3: move the surface up
F4: move the surface down
F5: move the surface back
F6: move the surface forward
}

fn-surface-help: func [][
    lv-lay: layout [
        backdrop 0.0.0 effect [gradient 0x1 130.255.230 0.150.0]
        vh1 "3D Surface Help"
        vtext help-text 400x600 as-is
    ]
    view/new lv-lay
]
fn-prefs: func [/hide-panel /local lv-err xl-new yl-new xh-new yh-new][
    if error? lv-err: try [xl-new: to decimal! f-xl/text][
        focus f-xl
        show f-xl
        alert "Invalid low x value"
        return
    ]
    if error? lv-err: try [yl-new: to decimal! f-yl/text][
        focus f-yl
        show f-yl
        alert "Invalid low y value"
        return
    ]
    if error? lv-err: try [xh-new: to decimal! f-xh/text][
        focus f-xh
        show f-xh
        alert "Invalid high x value"
        return
    ]
    if error? lv-err: try [yh-new: to decimal! f-yh/text][
        focus f-yh
        show f-yh
        alert "Invalid high y value"
        return
    ]
    if xh-new <= xl-new [
        focus f-xh
        show f-xh
        alert "The high x value must be greater than the low x value"
        return
    ]
    if yh-new <= yl-new [
        focus f-yh
        show f-yh
        alert "The high y value must be greater than the low y value"
        return
    ]
    xl: xl-new
    yl: yl-new
    xh: xh-new
    yh: yh-new
    if error? lv-err: try [squares-x-new: to integer! f-xsq/text][
        focus f-xsq
        show f-xsq
        alert "Invalid no of x squares"
        return
    ]
    if error? lv-err: try [squares-y-new: to integer! f-ysq/text][
        focus f-ysq
        show f-ysq
        alert "Invalid no of y squares"
        return
    ]
    if squares-x-new < 4 [
        focus f-xsq
        show f-xsq
        alert "No of squares must be >= 4"
        return
    ]
    if squares-x-new > 64 [
        focus f-xsq
        show f-xsq
        alert "No of squares must be <= 64"
        return
    ]
    if squares-y-new < 4 [
        focus f-ysq
        show f-ysq
        alert "No of squares must be >= 4"
        return
    ]
    if squares-y-new > 64 [
        focus f-ysq
        show f-ysq
        alert "No of squares must be <= 64"
        return
    ]
    squares-x: squares-x-new
    squares-y: squares-y-new
    fn-str: f-fun-str/text
    if error? lv-err: try [camera/1: to decimal! f-cx/text][
        focus f-cx
        show f-cx
        alert "The x Camera value is invalid"
        return
    ]
    if error? lv-err: try [camera/2: to decimal! f-cy/text][
        focus f-cy
        show f-cy
        alert "The y Camera value is invalid"
        return
    ]
    if error? lv-err: try [camera/3: to decimal! f-cz/text][
        focus f-cz
        show f-cz
        alert "The z Camera value is invalid"
        return
    ]
    anti-alias: f-anti-alias/data
    either f-pen/data [pen-color: f-pen-col/color][pen-color: none]
    poke clrs 2 f-top-c1/color
    poke clrs 1 f-top-c2/color
    poke clrs 3 f-btm-c1/color
    poke clrs 4 f-btm-c2/color
    clear objs
    fn-gen-plane white red xl yl xh yh squares-x squares-y
    fn-height fn-str xl xh yl yh squares-x squares-y
    foreach o objs [fn-rot o]
    fn-show
    if hide-panel [hide f-panel]
]
fn-high-chg: func [dx [integer!] dy [integer!]] [
    context [
        if error? lv-err: try [x: to integer! f-x-high/text][return]
        if error? lv-err: try [y: to integer! f-y-high/text][return]
        if all [dx = -1 x > 1][f-x-high/text: to string! (x - 1) x: x - 1]
        if all [dy = -1 y > 1][f-y-high/text: to string! (y - 1) y: y - 1]
        if all [dx = 1 x < squares-x][f-x-high/text: to string! (x + 1) x: x + 1]
        if all [dy = 1 y < squares-y][f-y-high/text: to string! (y + 1) y: y + 1]
        show [f-x-high f-y-high]
        poke clrs 6 f-htop-c1/color
        poke clrs 5 f-htop-c2/color
        poke clrs 8 f-hbtm-c1/color
        poke clrs 7 f-hbtm-c2/color
        fn-highlight x y 5 6 7 8
    ]
]
fn-highlight: func [x [integer!] y [integer!] col1 [integer!] col2 [integer!] col3 [integer!] col4 [integer!]][
    context [
        ; restore original colours
        if (high-sq-cols/1) > 0 [
            high-sq: high-sq-cols/1
            poke objs/1/5/:high-sq/3 2 high-sq-cols/2
            poke objs/1/5/:high-sq/3 3 high-sq-cols/3
            high-sq: high-sq + 1
            poke objs/1/5/:high-sq/3 2 high-sq-cols/4
            poke objs/1/5/:high-sq/3 3 high-sq-cols/5
            high-sq: high-sq + 1
            poke objs/1/5/:high-sq/3 2 high-sq-cols/6
            poke objs/1/5/:high-sq/3 3 high-sq-cols/7
            high-sq: high-sq + 1
            poke objs/1/5/:high-sq/3 2 high-sq-cols/8
            poke objs/1/5/:high-sq/3 3 high-sq-cols/9
        ]
        h-sq: (squares-x * squares-y) + ((x - 1) + ((y - 1) * squares-x)) + 1
        f-xh-val/text: to string! objs/1/2/:h-sq/1
        f-yh-val/text: to string! objs/1/2/:h-sq/2
        f-high-val/text: to string! objs/1/2/:h-sq/3
        show [f-xh-val f-yh-val f-high-val]
        ; set hightlight
        high-sq: 4 * ((x - 1) + ((y - 1) * squares-x)) + 1
        poke high-sq-cols 1 high-sq
        poke high-sq-cols 2 objs/1/5/:high-sq/3/2
        poke high-sq-cols 3 objs/1/5/:high-sq/3/3
        poke objs/1/5/:high-sq/3 2 col1
        poke objs/1/5/:high-sq/3 3 col3
        high-sq: high-sq + 1
        poke high-sq-cols 4 objs/1/5/:high-sq/3/2
        poke high-sq-cols 5 objs/1/5/:high-sq/3/3
        poke objs/1/5/:high-sq/3 2 col2
        poke objs/1/5/:high-sq/3 3 col4
        high-sq: high-sq + 1
        poke high-sq-cols 6 objs/1/5/:high-sq/3/2
        poke high-sq-cols 7 objs/1/5/:high-sq/3/3
        poke objs/1/5/:high-sq/3 2 col1
        poke objs/1/5/:high-sq/3 3 col3
        high-sq: high-sq + 1
        poke high-sq-cols 8 objs/1/5/:high-sq/3/2
        poke high-sq-cols 9 objs/1/5/:high-sq/3/3
        poke objs/1/5/:high-sq/3 2 col2
        poke objs/1/5/:high-sq/3 3 col4
        fn-show
    ]
]
fn-high-prefs: func [/hide-panel][
    if error? lv-err: try [x: to integer! f-x-high/text][
        focus f-x-high
        show f-x-high
        alert "Invalid x value"
        return
    ]
    if x < 1 [
        focus f-x-high
        show f-x-high
        alert "x value cannot be less than 1"
        return
    ]
    if x > squares-x [
        focus f-x-high
        show f-x-high
        alert "x value grater than the number of squres in the x direction"
        return
    ]
    if error? lv-err: try [y: to integer! f-y-high/text][
        focus f-y-high
        show f-y-high
        alert "Invalid y value"
        return
    ]
    if y < 1 [
        focus f-y-high
        show f-y-high
        alert "y value cannot be less than 1"
        return
    ]
    if y > squares-y [
        focus f-y-high
        show f-y-high
        alert "y value grater than the number of squres in the y direction"
        return
    ]
    poke clrs 6 f-htop-c1/color
    poke clrs 5 f-htop-c2/color
    poke clrs 8 f-hbtm-c1/color
    poke clrs 7 f-hbtm-c2/color
    fn-highlight x y 5 6 7 8
    if hide-panel [hide f-panel-h]
]
lv-lay: layout [
    backdrop 0.0.0 effect [gradient 0x1 130.255.230 0.150.0]
    origin 0x0
    at 0x0
    space 0x0
    across
    f-box: box screen effect [draw draw-bl] rate 60 edge [size: 1x1 color: gray effect: 'bevel]
    feel [
        engage: func [face action event][
            if all[action = 'time   rot][
                st: now/time/precise
                theta1: theta1 + 5
                theta2: theta2 + 7
                if theta1 > 360 [theta1: theta1 - 360]
                if theta2 > 360 [theta2: theta2 - 360]
                objs/1/1/4: objs/1/1/4 + 5
                objs/1/1/5: objs/1/1/5 + 7
                if objs/1/1/4 > 360 [objs/1/1/4: objs/1/1/4 - 360]
                if objs/1/1/5 > 360 [objs/1/1/5: objs/1/1/5 - 360]
                rots: now/time/precise
                foreach o objs [fn-rot o]
                rote: now/time/precise
                fn-show
                shoe: now/time/precise
                print [now/time/precise - st rote - rots shoe - rote]
            ]
        ]
    ]
    return
    sensor 0x0 keycode [F1 F2 F3 F4 F5 F6 F7 #">" #"<" #"{" #"}" #"[" #"]"] [
        switch value [
            #"[" [objs/1/1/4: objs/1/1/4 + 5 fn-rot objs/1 if objs/1/1/4 > 360 [objs/1/1/4: objs/1/1/4 - 360] fn-show-angles]
            #"]" [objs/1/1/4: objs/1/1/4 - 5 fn-rot objs/1 if objs/1/1/4 < 0 [objs/1/1/4: objs/1/1/4 + 360] fn-show-angles]
            #"<" [objs/1/1/5: objs/1/1/5 + 5 fn-rot objs/1 if objs/1/1/5 > 360 [objs/1/1/5: objs/1/1/5 - 360] fn-show-angles]
            #">" [objs/1/1/5: objs/1/1/5 - 5 fn-rot objs/1 if objs/1/1/5 < 0 [objs/1/1/5: objs/1/1/5 + 360] fn-show-angles]
            #"{" [objs/1/1/6: objs/1/1/6 - 5 fn-rot objs/1 if objs/1/1/6 < 0 [objs/1/1/6: objs/1/1/6 + 360] fn-show-angles]
            #"}" [objs/1/1/6: objs/1/1/6 + 5 fn-rot objs/1 if objs/1/1/6 > 360 [objs/1/1/6: objs/1/1/6 - 360] fn-show-angles]
            F1 [camera/1: camera/1 - 0.1 fn-show-cam]
            F2 [camera/1: camera/1 + 0.1 fn-show-cam]
            F3 [camera/2: camera/2 + 0.1 fn-show-cam]
            F4 [camera/2: camera/2 - 0.1 fn-show-cam]
            F5 [camera/3: camera/3 + 0.1 fn-show-cam]
            F6 [camera/3: camera/3 - 0.1 fn-show-cam]
        ]
        foreach o objs [fn-rot o]
        fn-show
    ]
    btn "Details" [show f-panel]
    btn "Help" [fn-surface-help]
    at 4x4
    f-panel: panel [
        across
        origin 4x4
        at 4x4
        space 4x4
        vtext "X" right 20
        f-xl: field 100
        f-xh: field 100
        return
        vtext "Y" right 20
        f-yl: field 100
        f-yh: field 100
        return
        vtext "Camera"
        return
        vtext "x" 20
        f-cx: field 204
        return
        vtext "y" 20
        f-cy: field 204
        return
        vtext "z" 20
        f-cz: field 204
        return
        f-fun-str: area 228x200 font-name "Courier" wrap
        return
        vtext "No of X-Squares" 100
        f-xsq: field 124
        return
        vtext "No of Y-Squares" 100
        f-ysq: field 124
        return
        f-anti-alias: check-line "Anti-Alias" true
        return
        f-pen: check-line "Pen"
        f-pen-col: box black 20x20 edge [size: 1x1] [
            lv-val: request-color/color f-pen-col/color
            either lv-val = none [f-pen/data: false]
            [f-pen/data: true f-pen-col/color: lv-val]
            show [f-pen f-pen-col]
        ]
        return
        vtext "Colors (Top)" 100
        f-top-c1: box 20x20 orange edge [size: 1x1] [
            lv-val: request-color/color f-top-c1/color
            if lv-val <> none [f-top-c1/color: lv-val]
            show [f-top-c1]
        ]
        f-top-c2: box 20x20 white edge [size: 1x1][
            lv-val: request-color/color f-top-c2/color
            if lv-val <> none [f-top-c2/color: lv-val]
            show [f-top-c2]
        ]
        return
        vtext "Colors (Bottom)" 100
        f-btm-c1: box 20x20 red edge [size: 1x1] [
            lv-val: request-color/color f-btm-c1/color
            if lv-val <> none [f-btm-c1/color: lv-val]
            show [f-btm-c1]
        ]
        f-btm-c2: box 20x20 white edge [size: 1x1][
            lv-val: request-color/color f-btm-c2/color
            if lv-val <> none [f-btm-c2/color: lv-val]
            show [f-btm-c1]
        ]
        return
        btn "Hightlight Square" [show f-panel-h] 112
        return
        btn "Hide" 112 [fn-prefs/hide-panel ]
        btn "Apply" 112 [fn-prefs]
    ] edge [size: 2x2 effect: 'ibevel]
    f-panel-h: panel [
        across
        origin 4x4
        at 4x4
        space 4x4
        vtext "Highlight square"
        return
        vtext "x:"
        f-x-high: field "1" 100
        space 0x0
        arrow left [fn-high-chg -1 0]
        space 4x4
        arrow right [fn-high-chg 1 0]
        return
        vtext "y:"
        f-y-high: field "1" 100
        space 0x0
        arrow left [fn-high-chg 0 -1]
        space 4x4
        arrow right [fn-high-chg 0 1]
        return
        vtext "Colors (Top)" 100
        f-htop-c1: box 20x20 0.0.150 edge [size: 1x1] [
            lv-val: request-color/color f-htop-c1/color
            if lv-val <> none [f-htop-c1/color: lv-val]
            show [f-htop-c1]
        ]
        f-htop-c2: box 20x20 0.0.200 edge [size: 1x1][
            lv-val: request-color/color f-htop-c2/color
            if lv-val <> none [f-htop-c2/color: lv-val]
            show [f-htop-c2]
        ]
        return
        vtext "Colors (Bottom)" 100
        f-hbtm-c1: box 20x20 200.200.200 edge [size: 1x1] [
            lv-val: request-color/color f-hbtm-c1/color
            if lv-val <> none [f-hbtm-c1/color: lv-val]
            show [f-hbtm-c1]
        ]
        f-hbtm-c2: box 20x20 255.200.200 edge [size: 1x1][
            lv-val: request-color/color f-hbtm-c2/color
            if lv-val <> none [f-hbtm-c2/color: lv-val]
            show [f-hbtm-c1]
        ]
        return
        vtext "x:" 50
        f-xh-val: info "0.0" 174 silver
        return
        vtext "y:" 50
        f-yh-val: info "0.0" 174 silver
        return
        vtext "f(x,y)" 50
        f-high-val: info "0.0" 174 silver
        return
        btn "Hide" 112 [fn-high-prefs/hide-panel ]
        btn "Apply" 112 [fn-high-prefs ]
    ] edge [size: 2x2 effect: 'ibevel] with [show?: false]
]
; 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!] y [any-type!]] [] f
]
rot: false
dist: 0.0
theta1: 0.0
theta2: 0.0
fn-height: func [fn [string!] x1 [decimal! integer!] x2 [decimal! integer!] y1 [decimal! integer!] y2 [decimal! integer!] xs [decimal! integer!] ys [decimal! integer!] /local c h][
    f-fx: create-function fn
    c: 0
    ; corners
    for i y1 (y2 + (((y2 - y1) / ys / 10))) (y2 - y1) / ys [
        for j x1 (x2 + ((x2 - x1) / xs / 10)) (x2 - x1) / xs [
            ; evaluate function

            if error? lv-err: try [h: f-fx i j][
                focus f-x-high
                show f-x-high
                alert rejoin ["Unable to evaluate function at " i " , " j]
                h: 0
            ]
            c: c + 1
            objs/1/2/:c/3: h
        ]
    ]
    ; centers
    c: (xs + 1) * (ys + 1)
    for i y1 + ((y2 - y1) / ys / 2) y2 - ((y2 - y1) / ys / 2) + ((y2 - y1) / ys / 10) (y2 - y1) / ys [
        for j x1 + ((x2 - x1) / xs / 2) x2 - ((x2 - x1) / xs / 2) + ((x2 - x1) / xs / 10) (x2 - x1) / xs [
            ; function goes here
            h: f-fx i j
            c: c + 1
            objs/1/2/:c/3: h
        ]
    ]
]
fn-str: "(2 * exp - ( ((0.5   * x) * (0.5 * x)) + ((0.5 * (y + -3.0)) * (0.5 * (y + -3.0)) ) )) + (4 * exp - ( ((0.5 * (x + 3.0)) * (0.5 * (x + 3.0))) + ((0.5 * (y + 3.0)) * (0.5 * (y + 3.0))) ) )"
; fn-str: "((i) * (i)) + ((j) * (j)) / 20"
f-fun-str/text: fn-str
xl: -8
yl: -8
xh: 8
yh: 8
f-xl/text: to string! xl
f-yl/text: to string! yl
f-xh/text: to string! xh
f-yh/text: to string! yh
squares-x: 16
squares-y: 16
f-xsq/text: to string! squares-x
f-ysq/text: to string! squares-y
high-sq-cols: [0 0 0 0 0 0 0 0 0]
f-fun-str/text: fn-str
f-cx/text: "0"
f-cy/text: "0"
f-cz/text: "20"
fn-prefs
; initial camera
objs/1/1/6: 250
objs/1/1/4: 60
pen-color: none
anti-alias: true
foreach o objs [fn-rot o]
fn-show
view lv-lay
quit

2 comments: