WuLines in Forth Code Addendum 01
Tim Trussell
\
\ For: Fast Antialiased Lines Using Wu's Algorithm
\
\ by Timothy Trussell
\
\ -------------------------------------------------------------------
\ This code is meant for use with the 32Forth system.
\ This is the DOS DPMI version of the compiler in Rick van Norman's
\ OS2FORTH.ZIP package, available on the Taygeta Scientific site at:
\
\ ftp://ftp.taygeta.com/pub/Forth/Compilers/native/OS-2/
\ -------------------------------------------------------------------
\ The high level Forth code should work on any other Forth system, if
\ the CODE primitives have been converted to work correctly.
\ -------------------------------------------------------------------
\ Save as WuTest.4th in your \os2forth\forth directory
\ This Code Addendum is stand-alone. All library modules have been
\ included in this source.
\ ---[ DDJ June 1992 - Michael Abrash ]------------------------------
\ Function to draw an antialiased line from (X0,Y0) to (X1,Y1), using
\ an antialiasing approach published by Xiaolin Wu in the July 1991
\ issue of Computer Graphics. Requires that the palette be set up so
\ that there are NumLevels intensity levels of the desired drawing
\ color, starting at color BaseColor (100% intensity) and followed by
\ (NumLevels-1) levels of evenly decreasing intensity, with color
\ (BaseColor+NumLevels-1) being 0% intensity of the desired drawing
\ color (black). This code is suitable for use at screen resolutions,
\ with lines typically no more than 1K long; for longer lines, 32-bit
\ error arithmetic must be used to avoid problems with fixed-point
\ inaccuracy. No clipping is performed in DrawWuLine; it must be
\ performed either at a higher level or in the DrawPixel function.
\ -------------------------------------------------------------------
\ Possibly and ANew from Wil Baden's ToolBelt 2002 package
exists POSSIBLY not [if]
: POSSIBLY ( "name" -- ) BL WORD FIND ?dup AND IF EXECUTE THEN ;
: ANEW ( "name" -- )( Run: -- ) >IN @ POSSIBLY >IN ! MARKER ;
[then]
anew [WuTest]
\ ------------
\ ---[ Prototypes ]--------------------------------------------------
\ ------------
\
\ ---[ Library Includes ]---
\
\ code SetMode ( mode -- )
\ : InitGraph ( mode -- )
\ : CloseGraph ( -- )
\ code CPortOut ( c addr -- )
\ code WaitRetrace ( -- )
\ EDO module
\ HeapAllot module
\ code BlitBuffer ( &buf -- )
\
\ ---[ Wu Line Demo ]---
\
\ : PutPixel ( &buf x y c -- )
\ : WuYMajor ( -- )
\ : WuXMajor ( -- )
\ : WuLine ( &buf X0 Y0 X1 Y1 c #lvls ibits -- )
\ : Line ( &buf x1 y1 x2 y2 c -- )
\ : SetWuPalette ( -- )
\ : Wu1 ( -- )
\ : Wu2 ( -- )
\ : Wu3 ( -- )
\ : Wu4 ( -- )
\ : Bres1 ( -- )
\ : Bres2 ( -- )
\ : Bres3 ( -- )
\ : Bres4 ( -- )
\ : WuTest ( -- )
\ : SeeWu ( -- )
\ : SeeBres ( -- )
\
\ ---[ Wireframe Cube Demo ]---
\
\ : CreateLookupTables ( -- )
\ : SetObject ( x y z obj# -- )
\ : InitCube ( -- )
\ : RotateVectors ( -- )
\ : DrawCube ( -- )
\ : cube ( -- )
\ ------------------------------------------------[End Prototypes]---
\ ------------------
\ ------------------------[ Library Includes ]-----------------------
\ ------------------
\ ---[ SetMode ]-----------------------------------------------------
\ Enter/Exit to/from graphics/text modes
code SetMode ( mode -- )
ax ax xor \ ah=Function #0
bl al mov \ al=mode to set
int10 #) call
bx pop
end-code
NO-EXPAND
: InitGraph ( mode -- ) SetMode ;
: CloseGraph ( -- ) 3 SetMode ;
\ ---------------------------------------------------[End SetMode]---
\ ---[ CPortOut ]----------------------------------------------------
\ Outputs an 8-bit value to the specified I/O port
\ Used by SetWuPalette
code CPortOut ( c addr -- )
\ addr in bx on entry
bx dx mov \ addr to dx
ax pop \ c to ax (al, specifically)
$EE C, \ OUT DX,AL
bx pop \ get new TOS
end-code
NO-EXPAND
\ --------------------------------------------------[End CPortOut]---
\ ---[ WaitRetrace ]-------------------------------------------------
\ Delay until start of the vertical retrace signal from the VGA card
code WaitRetrace ( -- )
$03DA # dx mov
1 L:
dx al in
8 # al test
1 L# jnz
2 L:
dx al in
8 # al test
2 L# jz
end-code
NO-EXPAND
\ -----------------------------------------------[End WaitRetrace]---
\ ---[ EDO ]---------------------------------------------------------
\ The Extended Data Objects package by GT Hawkins
1 CONSTANT 1BYTE
cell CONSTANT 1WORD
8 constant 1FLOAT
: BYTE* ;
: WORD+ ( n -- n+WORD ) 1WORD + ;
: WORD* ( n -- n*WORD ) 1WORD * ;
: DEF ( size -- ) CONSTANT ;
: S{ ( -- 0 ) 0 ;
: :: ( offset object-definition -- offset )
CREATE OVER , + DOES> @ + ;
: }S ( size -- ) \ definition name follows in input stream
CONSTANT ;
: [] ( object-definition #objects -- )
OVER * CONSTANT \ define the vector
CREATE , \ define the vector operator
DOES> @ * + ;
\ ---[ My additions to the EDO definition ]--------------------------
: FLOAT* ( n -- n*FLOAT ) FLOATS ;
1BYTE DEF {1BYTE}-DEF
2 BYTE* DEF {2BYTE}-DEF
4 BYTE* DEF {4BYTE}-DEF
1WORD DEF {1WORD}-DEF
2 WORD* DEF {2WORD}-DEF
8 BYTE* DEF {1FLOAT}-DEF
\ -------------------------------------------------------[End EDO]---
\ ---[ HeapAllot ]---------------------------------------------------
\ For allocating memory from the Forth Heap - the memory from the
\ end of the dictionary to the bottom of the stack.
value %EndHeap \ End of Heap pointer
value %HeapPtr \ Top of Heap pointer
SP@ 65536 - \ set end of heap to TOS-65536
\ change if you need more stack space
dup 16 mod - \ align to paragraph boundary
to %EndHeap
%EndHeap to %HeapPtr \ they are equal at initialization
: HeapAllot ( size "name" -- addr )
create \ =[Compile Time Functions]=
%HeapPtr over - \ calculate new TOS
dup 16 mod - \ align to lower paragraph boundary
dup , \ store address of new allocation
dup to %HeapPtr \ update to new TOS
swap 0 fill \ zero the memory block
does> \ =[Run Time Function]=
@ \ load start address of memory block
;
\ ------------------------------------------------[End Heap Allot]---
value VSelector $0A000 SEG>DESC to VSelector
\ ---[ BlitBuffer ]--------------------------------------------------
\ Copies a 64k double buffer to the video screen. 320x200x256 mode.
code BlitBuffer ( &buf -- )
es push \ save registers to modify
di push
si push
VSelector # ax mov
ax es mov \ es=selector
di di xor \ di=start of video display
bx si mov \ si=&buf
cld
16000 # cx mov
rep movs \ move the data
si pop \ restore registers
di pop
es pop
bx pop \ get new TOS
end-code
no-expand
\ ------------------------------------------------[End BlitBuffer]---
\ ---[ Global Constants ]--------------------------------------------
\ Required for the module to compile correctly
value ScreenW \ Already defined if VBELib has been
value ScreenH \ loaded for VESA resolutions.
value BufferSize
320 to ScreenW \ default to 320x200x256 Mode 13h
200 to ScreenH
ScreenW ScreenH * to BufferSize
64000 HeapAllot VBuffer \ double buffer to use
\ ----------
\ ---[ PutPixel ]----------------------------------------------------
\ ----------
\ Called by both Line and WuLine functions
: PutPixel ( &buf x y c -- )
swap >R -rot + R> \ c &buf[x] y
ScreenW * \ c &buf[x] y*ScreenW
+ \ c &buf[x+y*ScreenW]
C! \ --
;
\ -------------------------------
\ -----------------[ Wu Antialiased Line Algorithm ]-----------------
\ -------------------------------
\ : WuLine ( &buf X0 Y0 X1 Y1 c #lvls ibits -- )
\
\ &buf = address of double buffer to plot the line to
\ (X0,Y0) = start point coordinates of line
\ (X1,Y1) = end point coordinates of line
\ c = color # of first color in block used for antialiasing,
\ the 100% intensity version of the drawing color
\ #lvls = size of color block, with BaseColor+NumLevels-1 being
\ the 0% intensity version of the drawing color
\ ibits = log base 2 of NumLevels; the # of bits used to
\ describe the intensity of the drawing color.
\ 2**IntensityBits==NumLevels
value wuBuf \ address of screen buffer
value wuX0 \ line start x
value wuY0 \ line start y
value wuX1 \ line end x
value wuY1 \ line end y
value wuBaseColor \ see above
value wuNumLevels \ see above
value wuIntensityBits \ see above
value wuIntensityShift \ working variables for the module
value wuErrorAdj
value wuErrorAcc
value wuErrorAccTemp
value wuWeighting
value wuWeightingCMask
value wuDeltaX
value wuDeltaY
value wuXDir
\ --------------
\ ---[ Y-Major Line ]------------------------------------------------
\ --------------
\ Y-major line; calculate 16-bit fixed-point fractional part of a
\ pixel that X advances each time Y advances 1 pixel, truncating the
\ result so that we won't overrun the endpoint along the X axis
: WuYMajor ( -- )
\ Y-Major line - [wuDeltaY > wuDeltaX]
wuDeltaX 16 LSHIFT wuDeltaY / to wuErrorAdj
\ draw all pixels other than the first and last
begin
-1 +to wuDeltaY
wuDeltaY 0>
while
wuErrorAcc $FFFF AND to wuErrorAccTemp
wuErrorAdj +to wuErrorAcc
wuErrorAcc $FFFF AND to WuErrorAcc
wuErrorAcc wuErrorAccTemp <= if \ rollover?
wuXDir +to wuX0
then
1 +to wuY0
wuErrorAcc wuIntensityShift RSHIFT to wuWeighting
wuBuf
wuX0
wuY0
wuBaseColor wuWeighting +
PutPixel
wuBuf
wuX0 wuXDir +
wuY0
wuBaseColor wuWeighting wuWeightingCMask XOR +
PutPixel
repeat
;
\ --------------
\ ---[ X-Major Line ]------------------------------------------------
\ --------------
: WuXMajor ( -- )
\ it's an X-Major line
wuDeltaY 16 LSHIFT wuDeltaX / to wuErrorAdj
begin
-1 +to wuDeltaX
wuDeltaX 0>
while
wuErrorAcc $FFFF AND to wuErrorAccTemp
wuErrorAdj +to wuErrorAcc
wuErrorAcc $FFFF AND to WuErrorAcc
wuErrorAcc wuErrorAccTemp <= if \ rollover?
1 +to wuY0
then
wuXDir +to wuX0
wuErrorAcc wuIntensityShift RSHIFT to wuWeighting
wuBuf
wuX0
wuY0
wuBaseColor wuWeighting +
PutPixel
wuBuf
wuX0
wuY0 1+
wuBaseColor wuWeighting wuWeightingCMask XOR +
PutPixel
repeat
;
\ --------
\ ---[ WuLine ]------------------------------------------------------
\ --------
: WuLine ( &buf X0 Y0 X1 Y1 c #lvls ibits -- )
to wuIntensityBits
to wuNumLevels
to wuBaseColor
to wuY1
to wuX1
to wuY0
to wuX0
to wuBuf
\ Make sure the line runs top to bottom
wuY0 wuY1 > if
wuY0 wuY1 to wuY0 to wuY1
wuX0 wuX1 to wuX0 to wuX1
then
\ Draw the initial pixel, which is always exactly intersected by
\ the line and so needs no weighting
wuBuf wuX0 wuY0 wuBaseColor PutPixel
\ Determine if X moves left to right, or right to left
wuX1 wuX0 - dup to wuDeltaX 0 >= if
1 to wuXDir
else
wuDeltaX negate to wuDeltaX \ make DeltaX positive
-1 to wuXDir
then
\ Special case horizontal, vertical and diagonal lines, which
\ require no weighting because they go right through the center
\ of every pixel
wuY1 wuY0 - dup to wuDeltaY 0= if
\ Y0=Y1, Draw a horizontal line
wuDeltaX 0 do
wuXDir +to wuX0
wuBuf wuX0 wuY0 wuBaseColor PutPixel
loop
else
wuDeltaX 0= if
\ X0=X1, Draw a vertical line
wuDeltaY 0 do
1 +to wuY0
wuBuf wuX0 wuY0 wuBaseColor PutPixel
loop
else
wuDeltaX wuDeltaY = if
\ draw a diagonal line
wuDeltaY 0 do
wuXDir +to wuX0
1 +to wuY0
wuBuf wuX0 wuY0 wuBaseColor PutPixel
loop
else
\ Line is not horizontal, diagonal, or vertical
\ initialize the line error accumulator
0 to wuErrorAcc
\ #of bits by which to shift ErrorAcc to get intensity level
16 wuIntensityBits - to wuIntensityShift
\ mask used to flip all bits in an intensity weighting,
\ producing the result (1 - intensity weighting)
wuNumLevels 1- to wuWeightingCMask
\ is this an X-Major or Y-Major line
wuDeltaY wuDeltaX > if
WuYMajor
else
WuXMajor
then \ x/y-major
then \ diagonal
then \ vertical
then \ horizontal
\ draw the final pixel, which is always exactly intersected by
\ the line and so needs no weighting
wuBuf wuX1 wuY1 wuBaseColor PutPixel
;
\ ----------------------------------------------------[End WuLine]---
\ ---[ Bresenham Line ]----------------------------------------------
\ Draws a line from x1,y1 to x2,y2 in the color c to a buffer.
value %d
value %x
value %y
value %ax
value %ay
value %sx
value %sy
value %dx
value %dy
value %buf
value %x1
value %y1
value %x2
value %y2
value %c
: Line ( &buf x1 y1 x2 y2 c -- )
to %c
to %y2
to %x2
to %y1
to %x1
to %buf
%x2 %x1 - to %dx
%dx abs 1 LSHIFT to %ax
%dx 0< if -1 else 1 then to %sx
%y2 %y1 - to %dy
%dy abs 1 LSHIFT to %ay
%dy 0< if -1 else 1 then to %sy
%x1 to %x
%y1 to %y
%ax %ay > if
%ay %ax 1 RSHIFT - to %d
begin
%x %x2 = not
while
%buf %x %y %c PutPixel
%d 0 >= if
%sy +to %y
%ax negate +to %d
then
%sx +to %x
%ay +to %d
repeat
else \ ax not > ay
%ax %ay 1 RSHIFT - to %d
begin
%y %y2 = not
while
%buf %x %y %c PutPixel
%d 0 >= if
%sx +to %x
%ay negate +to %d
then
%sy +to %y
%ax +to %d
repeat
then
;
\ ------------------------------------------------------[End Line]---
\ ---[ Type Definitions ]--------------------------------------------
S{
{1WORD}-DEF :: .BaseColor
{1WORD}-DEF :: .NumLevels
{1WORD}-DEF :: .IntensityBits
{1WORD}-DEF :: .MaxRed
{1WORD}-DEF :: .MaxGreen
{1WORD}-DEF :: .MaxBlue
}S wucolor-obj
wucolor-obj 2 [] wucolors[]-obj wucolor-ndx
S{
{1BYTE}-DEF :: .red
{1BYTE}-DEF :: .green
{1BYTE}-DEF :: .blue
}S pal-obj
pal-obj 256 [] pal[]-obj pal-ndx
{1BYTE}-DEF 64 [] gamma[]-obj gamma-ndx
\ ---[ Array Allocations ]-------------------------------------------
pal[]-obj HeapAllot Pal[]
2 constant NumWuColors \ # of colors we'll do aa drawing with
0 constant WU_Blue
1 constant WU_White
create WuColors[]
192 , 32 , 5 , 0 , 0 , 63 , \ blue
224 , 32 , 5 , 63 , 63 , 63 , \ white
\ Gamma-corrected DAC color components for 64 linear levels from
\ 0% to 100% intensity
create GammaTable[]
0 C, 10 C, 14 C, 17 C, 19 C, 21 C, 23 C, 24 C,
26 C, 27 C, 28 C, 29 C, 31 C, 32 C, 33 C, 34 C,
35 C, 36 C, 37 C, 37 C, 38 C, 39 C, 40 C, 41 C,
41 C, 42 C, 43 C, 44 C, 44 C, 45 C, 46 C, 46 C,
47 C, 48 C, 48 C, 49 C, 49 C, 50 C, 51 C, 51 C,
52 C, 52 C, 53 C, 53 C, 54 C, 54 C, 55 C, 55 C,
56 C, 56 C, 57 C, 57 C, 58 C, 58 C, 59 C, 59 C,
60 C, 60 C, 61 C, 61 C, 62 C, 62 C, 63 C, 63 C,
\ --------------
\ ---[ SetWuPalette ]------------------------------------------------
\ --------------
\ Sets up the palette for antialiasing with the specified colors.
\ Intensity steps for each color are scaled from the full desired
\ intensity of the red, green, and blue components for that color
\ down to 0% intensity; each step is rounded to the nearest integer.
\ Colors are corrected for a gamma of 2.3. The values that the
\ palette is programmed with are hardwired for the VGA's 6 bit per
\ color DAC.
\ -------------------------------------------------------------------
\ This should probably be placed in the WULINE.4TH file, as the line
\ drawing routine is incomplete without it, but it uses the EDO code,
\ and I'm not wanting to add that to WULINE.4TH at the moment.
\ -------------------------------------------------------------------
floating
\ This sets palette locations 192..223 and 224..255
value %WC[j]
value %Pal[i]
: SetWuPalette ( -- )
NumWuColors 0 do
WuColors[] i wucolor-ndx to %WC[j]
32 0 do
Pal[] %WC[j] .BaseColor @ i + pal-ndx to %Pal[i]
GammaTable[] \ G[]
%WC[j] .MaxRed @ S>F \ G[] .mr
1.0 \ G[] .mr 1.0
i S>F
31.0 F/ \ G[] .mr 1.0 i/31.0
F- \ G[] .mr 1.0-i/31.0
F* \ G[] .mr*(1.0-i/31.0)
0.5 F+ \ G[] .mr*(1.0-i/31.0)+0.5
F>S \ G[] n
gamma-ndx C@ \ c
%Pal[i] .red C! \ --
GammaTable[] %WC[j] .MaxGreen @ S>F
1.0 i S>F 31.0 F/ F- F* 0.5 F+ F>S gamma-ndx C@
%Pal[i] .green C!
GammaTable[] %WC[j] .MaxBlue @ S>F
1.0 i S>F 31.0 F/ F- F* 0.5 F+ F>S gamma-ndx C@
%Pal[i] .blue C!
loop
loop
192 $03C8 CPortOut
256 192 do
Pal[] i pal-ndx >R
R@ .red C@ $03C9 CPortOut
R@ .green C@ $03C9 CPortOut
R> .blue C@ $03C9 CPortOut
loop
;
integer
\ ---------------
\ ---[ Wu-Lines Demo ]-----------------------------------------------
\ ---------------
\ Draws four demo patterns using the Wu-Lines Algorithm
: Wu1 ( -- )
5
begin
dup ScreenW <
while
VBuffer
ScreenW 2/ ScreenW 10 / - 2 pick 5 / +
ScreenH 5 /
3 pick
ScreenH 1-
WuColors[] WU_Blue wucolor-ndx >R
R@ .BaseColor @
R@ .NumLevels @
R> .IntensityBits @
WuLine
10 +
repeat
drop
;
: Wu2
5
begin
dup ScreenH <
while
VBuffer
ScreenW 2/ ScreenW 10 / -
2 pick 5 /
0
4 pick
WuColors[] WU_Blue wucolor-ndx >R
R@ .BaseColor @
R@ .NumLevels @
R> .IntensityBits @
WuLine
10 +
repeat
drop
;
: Wu3
5
begin
dup ScreenH <
while
VBuffer
ScreenW 2/ ScreenW 10 / +
2 pick 5 /
ScreenW 1-
4 pick
WuColors[] WU_Blue wucolor-ndx >R
R@ .BaseColor @
R@ .NumLevels @
R> .IntensityBits @
WuLine
10 +
repeat
drop
;
: Wu4
0
begin
dup ScreenW <
while
VBuffer
ScreenW 2/ ScreenW 10 / - 2 pick 5 / +
ScreenH
3 pick
0
WuColors[] WU_White wucolor-ndx >R
R@ .BaseColor @
R@ .NumLevels @
R> .IntensityBits @
WuLine
10 +
repeat
drop
;
\ -------------------
\ ---[ Bresenham Version ]-------------------------------------------
\ -------------------
\ Draws the same pattern, but using the Bresenham Line Algorithm
: Bres1
0
begin
dup ScreenW <
while
VBuffer
ScreenW 2/ ScreenW 10 / - 2 pick 5 / +
ScreenH 5 /
3 pick
ScreenH 1-
WuColors[] WU_Blue wucolor-ndx .BaseColor @
Line
10 +
repeat
drop
;
: Bres2
0
begin
dup ScreenH <
while
VBuffer
ScreenW 2/ ScreenW 10 / -
2 pick 5 /
0
4 pick
WuColors[] WU_Blue wucolor-ndx .BaseColor @
Line
10 +
repeat
drop
;
: Bres3
0
begin
dup ScreenH <
while
VBuffer
ScreenW 2/ ScreenW 10 / +
2 pick 5 /
ScreenW 1-
4 pick
WuColors[] WU_Blue wucolor-ndx .BaseColor @
Line
10 +
repeat
drop
;
: Bres4
0
begin
dup ScreenW <
while
VBuffer
ScreenW 2/ ScreenW 10 / - 2 pick 5 / +
ScreenH
3 pick
0
WuColors[] WU_White wucolor-ndx .BaseColor @
Line
10 +
repeat
drop
;
\ --------
\ ---[ WuTest ]------------------------------------------------------
\ --------
\ Shows first the Wu-Lines version, and then the Bresenham version
\ of the demo. Alternates with enough of a delay so that you can get
\ a good look at the difference between the line algorithms
: WuHelp
cr
cr ." +---------------------------------------------+"
cr ." | Wu Lines Algorithm Demo |"
cr ." +---------------------------------------------+"
cr ." | Original code by Michael Abrash |"
cr ." | 32Forth Conversion by Timothy Trussell |"
cr ." +---------------------------------------------+"
cr ." Routines: WuTest SeeWu SeeBres Cube"
cr
cr ." In WuTest: press ESC to exit"
cr ." For the others, press the <ANYKEY>"
cr
;
: VRDelay ( time -- )
dup 1 > if
0 do
WaitRetrace
loop
else \ allows for 0 or 1 to be passed
drop
WaitRetrace
then
;
: WuTest ( -- )
$13 InitGraph
SetWuPalette
begin
key? not
while
VBuffer BufferSize 0 fill
Wu1 Wu2 Wu3 Wu4
VBuffer BlitBuffer
50 VRDelay
VBuffer BufferSize 0 fill
Bres1 Bres2 Bres3 Bres4
VBuffer BlitBuffer
50 VRDelay
repeat
key drop
CloseGraph
WuHelp
;
\ -------
\ ---[ SeeWu ]-------------------------------------------------------
\ -------
\ Shows just the Wu-Lines version of the demo
: SeeWU
$13 InitGraph
SetWuPalette
VBuffer BufferSize 0 fill
Wu1 Wu2 Wu3 Wu4
VBuffer BlitBuffer
key drop
CloseGraph
WuHelp
;
\ ---------
\ ---[ SeeBres ]-----------------------------------------------------
\ ---------
\ Shows just the Bresenham Algorithm line version of the demo
: SeeBres ( -- )
$13 InitGraph
SetWuPalette
VBuffer BufferSize 0 fill
Bres1 Bres2 Bres3 Bres4
VBuffer BlitBuffer
key drop
CloseGraph
WuHelp
;
\ ---------------------
\ ---------------------[ Wireframe Cube Demo ]-----------------------
\ ---------------------
\ Wanted to see how the WuLine routine worked in an animation, and it
\ seems to work extremely well, especially when comparing it to the
\ original Bresenham lines. I'm not doing both line styles here, just
\ the WuLines version for the Cube demo.
\ ---[ Type Definitions ]--------------------------------------------
{1FLOAT}-DEF 360 [] sc[]-obj sc-ndx
S{
{1WORD}-DEF :: .cX
{1WORD}-DEF :: .cY
{1WORD}-DEF :: .cZ
}S cube-obj
S{
{1WORD}-DEF :: .pa
{1WORD}-DEF :: .pb
}S seg-obj
cube-obj 8 [] cube[]-obj cube-ndx
seg-obj 12 [] cseg[]-obj cseg-ndx
\ ---[ Array Allocations ]-------------------------------------------
sc[]-obj HeapAllot Sine[]
sc[]-obj HeapAllot Cosine[]
cube[]-obj HeapAllot Cube[]
cube[]-obj HeapAllot Temp[]
\ Specify the line segments that make up the cube
create CSegs[]
0 , 1 , \ a to b
1 , 2 , \ b to c
2 , 3 , \ c to d
3 , 0 , \ d to a
4 , 5 , \ e to f
5 , 6 , \ f to g
6 , 7 , \ g to h
7 , 4 , \ h to e
0 , 4 , \ a to e
1 , 5 , \ b to f
2 , 6 , \ c to g
3 , 7 , \ d to h
\ ---[ Sine Tables ]-------------------------------------------------
floating
: CreateLookupTables ( -- )
360 0 do
i S>F 3.14159265 F* 180.0 F/ FSINCOS
Cosine[] i sc-ndx F!
Sine[] i sc-ndx F!
loop
;
integer
\ ---[ Create Vector Object ]----------------------------------------
: SetObject ( x y z obj# -- )
cube[] swap cube-ndx >R
R@ .cZ !
R@ .cY !
R> .cX !
;
: InitCube ( -- )
-35 35 -35 0 SetObject \ back top left coords
-35 -35 -35 1 SetObject \ back bottom left coords
35 -35 -35 2 SetObject \ back bottom right coords
35 35 -35 3 SetObject \ back top right coords
-35 35 35 4 SetObject \ front top left coords
-35 -35 35 5 SetObject \ front bottom left coords
35 -35 35 6 SetObject \ front bottom right coords
35 35 35 7 SetObject \ front top right coords
;
\ ---[ RotateVectors ]-----------------------------------------------
\ Perform calculations to rotate the vector object
value %nx
value %ny
value %nz
value xangle
value yangle
value zangle
value distance
value direction
floating
: RotateVectors ( -- )
8 0 do
cube[] i cube-ndx >R
R@ .cY @ S>F Cosine[] xangle sc-ndx F@ F*
R@ .cZ @ S>F Sine[] xangle sc-ndx F@ F* F- F>S to %ny
R@ .cY @ S>F Sine[] xangle sc-ndx F@ F*
R@ .cZ @ S>F Cosine[] xangle sc-ndx F@ F* F+ F>S to %nz
R> .cX @ to %nx
temp[] i cube-ndx >R
%nx R@ .cX !
%ny R@ .cY !
%nz R@ .cZ !
R@ .cX @ S>F Cosine[] yangle sc-ndx F@ F*
R@ .cZ @ S>F Sine[] yangle sc-ndx F@ F* F+ F>S to %nx
R@ .cX @ negate S>F Sine[] yangle sc-ndx F@ F*
R@ .cZ @ S>F Cosine[] yangle sc-ndx F@ F* F+ F>S to %nz
%nx R@ .cX !
%nz R@ .cZ !
R@ .cX @ S>F Cosine[] zangle sc-ndx F@ F*
R@ .cY @ S>F Sine[] zangle sc-ndx F@ F* F- F>S to %nx
R@ .cX @ S>F Sine[] zangle sc-ndx F@ F*
R@ .cY @ S>F Cosine[] zangle sc-ndx F@ F* F+ F>S to %ny
%nx R@ .cX !
%ny R@ .cY !
R@ .cZ @ distance - R@ .cZ !
R@ .cX @ 256 * R@ .cZ @ / ScreenW 2/ + R@ .cX !
R@ .cY @ 256 * R@ .cZ @ / ScreenH 2/ + R> .cY !
loop
;
\ ---[ DrawCube ]----------------------------------------------------
\ Draw the vector object to the buffer, then blit to the screen
: DrawCube ( -- )
RotateVectors
12 0 do
VBuffer \ draw image to buffer
CSegs[] i cseg-ndx >R
temp[] R@ .pa @ cube-ndx dup .cX @ swap .cY @
temp[] R> .pb @ cube-ndx dup .cX @ swap .cY @
WuColors[] WU_Blue wucolor-ndx .BaseColor @
WuColors[] WU_Blue wucolor-ndx .NumLevels @
WuColors[] WU_Blue wucolor-ndx .IntensityBits @
WuLine
loop
VBuffer BlitBuffer \ display buffer data
VBuffer BufferSize 0 fill \ erase display buffer
;
\ ---[ Cube ]--------------------------------------------------------
\ Ties all the wireframe vector code together
: Cube ( -- )
25 to xangle \ init variables and arrays
125 to yangle
275 to zangle
200 to distance
VBuffer BufferSize 0 fill
CreateLookupTables \ init the sine/cosine tables
InitCube \ init the cube[] structure
$13 InitGraph \ init graphics mode
SetWuPalette \ init the palette
begin
key? not \ repeat while no key has been pressed
while
\ update the angles
3 +to xangle xangle 359 > if 0 to xangle then
3 +to yangle yangle 359 > if 0 to yangle then
-2 +to zangle zangle 1 < if 359 to zangle then
2 VRDelay
DrawCube
repeat
key drop \ absorb/lose the keypress
CloseGraph \ exit graphics mode
WuHelp \ display the help screen info again
;
WuHelp