Draw a sphere: Difference between revisions

=={{header|Forth}}==

{{works with|gforth|0.7.3}}

Inspired by C version but simplified.

Traditionaly, Forth use Fixed-Point Arithmetic (here with a 1000 scale). Integer square root function is hand coded.

===ASCII output===

<lang forth>: 3dup 2 pick 2 pick 2 pick ;

: sqrt ( u -- sqrt ) ( Babylonian method )

dup 2/ ( first square root guess is half )

dup 0= if drop exit then ( sqrt[0]=0, sqrt[1]=1 )

begin dup >r 2dup / r> + 2/ ( stack: square old-guess new-guess )

2dup > while ( as long as guess is decreasing )

nip repeat ( forget old-guess and repeat )

drop nip ;

: normalize ( x1 y1 z1 -- x1' y1' z1' ) ( normalise down to 1000 )

3dup dup * rot dup * rot dup * + + sqrt 1000 / >r ( length )

r@ / rot r@ / rot r> / rot ;

: r2-y2-x2 ( x y r -- z2 ) dup * swap dup * - swap dup * - ;

: shade ( u -- c ) C" @#&eo%*!:. " + c@ ;

: map-to-shade ( u -- u ) 0 shade * 1000 / 1 max 0 shade min ;

: dot-light ( x y z -- i ) ( hard coded light vector z, y, x )

-770 * rot 461 * rot 461 * + +

0 min 1000 / ;

: intensity ( x y z -- u ) dot-light dup * 1000 / map-to-shade ;

: pixel ( x y r -- c )

3dup r2-y2-x2 dup 0> if ( if in disk )

sqrt nip normalize intensity shade ( z=sqrt[r2-x2-y2] )

else 2drop 2drop bl ( else blank )

then ;

: draw ( r -- ) ( r x1000 )

1000 * dup dup negate do

cr

dup dup negate do

dup I 500 + J 500 + rot pixel emit

500 +loop

1000 +loop drop ;

20 draw

10 draw</lang>

{{out}}

<pre> eeooooeeeeee&&&##

o%%%%******%%%%%%ooooeee&&&##@@

o%**!!!!!!!!!!!!*****%%%%oooeee&&&##@@@

%*!!!:::::::::::::!!!!!****%%%oooeee&&&##@@@@

%*!!:::............:::::!!!!****%%%oooeee&&###@@@@@

%*!::...... ........::::!!!!***%%%oooeee&&&##@@@@@@

%!!::... .....::::!!!!***%%%oooeee&&&##@@@@@@@

%*!::... .....::::!!!****%%%oooee&&&###@@@@@@@@

*!::... .....:::!!!!***%%%oooeee&&&###@@@@@@@@

o*!::.. .....::::!!!***%%%oooeee&&&###@@@@@@@@@@

o*!::.. .....::::!!!***%%%oooeee&&&####@@@@@@@@@@

o*!::... ....::::!!!!***%%%oooeee&&&&###@@@@@@@@@@@

o*!!::.. .....::::!!!****%%%oooeee&&&####@@@@@@@@@@@@

%*!::... .....::::!!!!***%%%%oooeee&&&####@@@@@@@@@@@@

o%*!::.... .....::::!!!!****%%%oooeeee&&&###@@@@@@@@@@@@@@

%**!:::.... ......::::!!!!****%%%ooooeee&&&####@@@@@@@@@@@@@@

e%**!!::..... .......:::::!!!!****%%%ooooeee&&&&####@@@@@@@@@@@@@@@

o%**!!::::.....................:::::!!!!*****%%%ooooeee&&&&####@@@@@@@@@@@@@@@@

o%%**!!:::::...............:::::::!!!!!****%%%%ooooeeee&&&####@@@@@@@@@@@@@@@@@

eo%***!!!:::::::......:::::::::!!!!!!****%%%%%ooooeee&&&&####@@@@@@@@@@@@@@@@@@

eo%%***!!!!:::::::::::::::::!!!!!!******%%%%ooooeeee&&&&####@@@@@@@@@@@@@@@@@@@

eeo%%****!!!!!!!!::::!!!!!!!!!!******%%%%%oooooeeee&&&&####@@@@@@@@@@@@@@@@@@@@

&eoo%%%*****!!!!!!!!!!!!!!!********%%%%%oooooeeee&&&&&####@@@@@@@@@@@@@@@@@@@@@

#&eooo%%%%*********************%%%%%%ooooooeeee&&&&&#####@@@@@@@@@@@@@@@@@@@@@@

&&eeooo%%%%%%************%%%%%%%%ooooooeeeee&&&&&#####@@@@@@@@@@@@@@@@@@@@@@@

#&&eeeoooo%%%%%%%%%%%%%%%%%%%oooooooeeeeee&&&&&#####@@@@@@@@@@@@@@@@@@@@@@@@@

##&&eeeeoooooooooooooooooooooooeeeeeee&&&&&&#####@@@@@@@@@@@@@@@@@@@@@@@@@@

@##&&&eeeeeeooooooooooooooeeeeeeeee&&&&&&######@@@@@@@@@@@@@@@@@@@@@@@@@@@@

@@##&&&&&eeeeeeeeeeeeeeeeeeee&&&&&&&&#######@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

@@@###&&&&&&&&&&&&&&&&&&&&&&&&&&########@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

@@@@######&&&&&&&&&&&&&&&##########@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

@@@@@@#######################@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

@@@@@@@@@@@@########@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

@@@@@@@@@@@@@@@@@

o%%%%%%ooe&#@

*!::...:::!!*%%oe&&#@

*:. ..::!!*%ooe&#@@@

*: ..:!!*%ooe&#@@@@

!. ..::!*%%oe&&#@@@@

!. ..::!*%%oee&#@@@@@

!: ..:!!*%%oe&&#@@@@@@

%!. ..:!!**%ooe&&#@@@@@@@

%!:. ..::!!**%ooe&&##@@@@@@@

%!::.. ...:::!!*%%ooee&##@@@@@@@@

o*!!::.......:::!!!**%%oee&&##@@@@@@@@@

eo%*!!!!:::!!!!!**%%%ooee&&##@@@@@@@@@@

#eo%%**********%%%ooeee&&##@@@@@@@@@@@@

#&eooo%%%%%%ooooeee&&&###@@@@@@@@@@@@

##&&eeeeeeeeee&&&&###@@@@@@@@@@@@@@

@@##&&&&&&&&#####@@@@@@@@@@@@@@@@

@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

@@@@@@@@@@@@@@@@@@@@@@@@@@@

@@@@@@@@@@@@@@@@@@@@@

@@@@@@@@@@@@@ ok</pre>

===PGM output===

The same program as the ASCII one is translated to produce a PGM portable pixmap image file.

<lang forth>: 3dup 2 pick 2 pick 2 pick ;

: sqrt ( u -- sqrt ) ( Babylonian method )

dup 2/ ( first square root guess is half )

dup 0= if drop exit then ( sqrt[0]=0, sqrt[1]=1 )

begin dup >r 2dup / r> + 2/ ( stack: square old-guess new-guess )

2dup > while ( as long as guess is decreasing )

nip repeat ( forget old-guess and repeat )

drop nip ;

: normalize ( x1 y1 z1 -- x1' y1' z1' ) ( normalise down to 1000 )

3dup dup * rot dup * rot dup * + + sqrt 1000 / >r ( length )

r@ / rot r@ / rot r> / rot ;

: r2-y2-x2 ( x y r -- z2 ) dup * swap dup * - swap dup * - ;

0 value fileidstore

: image-open ( r -- )

outfile-id to fileidstore

s" sphere.pgm" w/o create-file throw to outfile-id

s\" P2\n" type 2* dup . .

s\" \n255" type ;

: image-close outfile-id close-file throw fileidstore to outfile-id ;

: map-to-shade 255 * 1000 / 1 max 255 min ;

: dot-light ( x y z -- i ) ( hard coded light vector z, y, x )

-770 * rot 461 * rot 461 * + +

0 min 1000 / ;

: intensity ( x y z -- u ) dot-light dup * 1000 / map-to-shade ;

: pixel ( x y r -- c )

3dup r2-y2-x2 dup 0> if ( if in disk )

sqrt nip normalize intensity ( z=sqrt[r2-x2-y2] )

else 2drop 2drop 255 ( else blank )

then ;

: draw ( r -- ) ( r x1000 )

dup image-open

1000 * dup dup negate do

cr

dup dup negate do

dup I 500 + J 500 + rot pixel .

1000 +loop

1000 +loop drop image-close ;

200 draw</lang>