Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : BOXLIB.ZIP
Filename : BOX.PRG

/*
BOX.PRG
Copyright (c) 1989, 1990, The Leylan Factor

The Leylan Factor
98-626 Moanalua Loop, #201
Aiea, HI 96701-5172

(808) 487-2230

Compuserve : 74216,3212

distribute freely with this header intact

Compile : clipper box /n/w
*/

#include "inkey.ch"
#include "set.ch"
#include "setcurs.ch"
#include "boxlib.ch"

/* define system constants */
#define TRUE .T.
#define FALSE .F.

#define ON .T.
#define OFF .F.

#define M1_EXIT 0
#define M1_MSHIFT 1
#define M1_MSIZE 2
#define M1_MFRAME 3
#define M1_MTITLE 4
#define M1_BSIZE 5
#define M1_BSHIFT 6
#define M1_BMSG 7
#define M1_MEMTTL 8
#define M1_MEMBLK 9
#define M1_MEMRUN 10
#define M1_VIDEO25 11
#define M1_VIDEO43 12

/* declare menu */
STATIC aMenu := { { "Menu RePosition " ,;
"Menu ReSize " ,;
"Menu ReFrame " ,;
"Menu ReTitle " ,;
"Background ReSize " ,;
"Background RePosition " ,;
"Background ReMessage " ,;
"Total Free Memory " ,;
"Largest Memory Block " ,;
"RUN Memory Available " ,;
"24 Line Video Mode " ,;
"43 Line Video Mode "}, 1, 1 }

/* disambiguate getlist to avoid compiler warning */
MEMVAR getlist


FUNCTION Main( lColor )
LOCAL xCursor, xScoreBoard, cColor, nShell, nKey
LOCAL bhArea, bhBgnd, bhMenu
LOCAL cMessage := "A Box Demo ... "
LOCAL nMaxR := (MAXROW() + 1)
LOCAL nMaxC := (MAXCOL() + 1)

LOCAL aVmode := { OFF, nMaxR, nMaxC }

/* set dos error code */
ERRORLEVEL(1)

/* init video mode */
lColor := IF( PCOUNT() == 0, ISCOLOR(), ;
IF( UPPER(lColor) == "-M", FALSE, ISCOLOR() ))

/* set environment */
xCursor := SET( _SET_CURSOR, SC_NONE )
xScoreBoard := SET( _SET_SCOREBOARD, OFF )

/* define domain */
bhArea := BoxNew( 0, 0, nMaxR, nMaxC, "N/N", 0, " ", '' )

/* define background */
cColor := IF( lColor, "+W/B,+GR/W,,,+W/B", "+W/N,N/W,,,+W/N" )
bhBgnd := BoxNew( 0, 0, 25, 80, cColor, 0, " ", '' )

/* define menu */
cColor := IF( lColor, "+W/BG,+GR/W,,,+W/BG", "N/W,+W/N,,,N/W" )
bhMenu := BoxNew( 0, 0, 9, 36, cColor, 1, "ÚÄ¿³ÙÄÀ³ ", " The Box Menu " )

CLS

/* draw background */
BoxShow( bhBgnd )

/* fill background */
FillBox( bhBgnd, cMessage )

/* draw menu */
BoxShow( bhMenu )

nShell := 1
WHILE (nShell > 0)

nKey := BoxPick( bhMenu, aMenu )

DO CASE

CASE nKey == M1_EXIT
nShell := 0

CASE nKey == M1_MSHIFT
BoxDrag( bhMenu, bhArea )

IF !( LASTKEY() == K_ESC )
BoxUnshow( bhMenu )
BoxShow( bhMenu )
ENDIF

CASE nKey == M1_MSIZE
BoxSize( bhMenu, bhArea )

if !( LASTKEY() == K_ESC )
BoxUnshow( bhMenu )
BoxShow( bhMenu )
endif

CASE nKey == M1_MFRAME
ReFrame( bhMenu )

CASE nKey == M1_MTITLE
ReTitle( bhMenu, lColor )

CASE nKey == M1_BSIZE
BoxUnshow( bhMenu)
BoxSize( bhBgnd, bhArea )

IF !( LASTKEY() == K_ESC )
BoxUnshow( bhBgnd )
BoxShow( bhBgnd )
ENDIF

FillBox( bhBgnd, cMessage )
BoxShow( bhMenu )

CASE nKey == M1_BSHIFT
BoxUnshow( bhMenu )
BoxDrag( bhBgnd, bhArea )

IF !( LASTKEY() == K_ESC )
BoxUnshow( bhBgnd )
BoxShow( bhBgnd )
ENDIF

FillBox( bhBgnd, cMessage )
BoxShow( bhMenu )

CASE nKey == M1_BMSG
BoxUnshow( bhMenu )
cMessage := ReMessage( bhBgnd, lColor, cMessage )

FillBox( bhBgnd, cMessage )
BoxShow( bhMenu )

CASE nKey == M1_MEMTTL
ShowMem( bhMenu, 0 )

CASE nKey == M1_MEMBLK
ShowMem( bhMenu, 1 )

CASE nKey == M1_MEMRUN
ShowMem( bhMenu, 2 )

CASE nKey == M1_VIDEO25
BoxUnshow( bhMenu )
BoxUnshow( bhBgnd )

IF SETMODE( 25, 80 )

aVmode[ 1 ] := ON

nMaxR := (MAXROW() + 1)
nMaxC := (MAXCOL() + 1)

BoxLength( bhArea, nMaxR )
BoxWidth( bhArea, nMaxC )

ELSE
AEVAL( { 100, 100 }, {| nPitch | TONE( nPitch, 1 ) } )

ENDIF

BoxTop( bhBgnd, MIN( BoxTop( bhBgnd ), MAX( BoxBottom( bhArea ) - BoxLength( bhBgnd ), 0 ) ) )
BoxLeft( bhBgnd, MIN( BoxLeft( bhBgnd ), MAX( BoxRight( bhArea ) - BoxWidth( bhBgnd ), 0 ) ) )
BoxLength( bhBgnd, MIN( BoxLength( bhBgnd ), nMaxR) )
BoxWidth( bhBgnd, MIN( BoxWidth( bhBgnd ), nMaxC ) )
BoxShow( bhBgnd )
FillBox( bhBgnd, cMessage )

BoxTop( bhMenu, MIN( BoxTop( bhMenu ), MAX( BoxBottom( bhArea ) - BoxLength( bhMenu ), 0 ) ) )
BoxLeft( bhMenu, MIN( BoxLeft( bhMenu ), MAX( BoxRight( bhArea ) - BoxWidth( bhMenu ), 0 ) ) )
BoxLength( bhMenu, MIN( BoxLength( bhMenu ), nMaxR) )
BoxWidth( bhMenu, MIN( BoxWidth( bhMenu ), nMaxC ) )
BoxShow( bhMenu )


CASE nKey == M1_VIDEO43
BoxUnshow( bhMenu )
BoxUnshow( bhBgnd )

IF SETMODE( 43, 80 )

aVmode[ 1 ] := ON

nMaxR := (MAXROW() + 1)
nMaxC := (MAXCOL() + 1)

BoxLength( bhArea, nMaxR )
BoxWidth( bhArea, nMaxC )

ELSE
AEVAL( { 100, 100 }, {| nPitch | TONE( nPitch, 1 ) } )

ENDIF

BoxTop( bhBgnd, MIN( BoxTop( bhBgnd ), MAX( BoxBottom( bhArea ) - BoxLength( bhBgnd ), 0 ) ) )
BoxLeft( bhBgnd, MIN( BoxLeft( bhBgnd ), MAX( BoxRight( bhArea ) - BoxWidth( bhBgnd ), 0 ) ) )
BoxLength( bhBgnd, MIN( BoxLength( bhBgnd ), nMaxR) )
BoxWidth( bhBgnd, MIN( BoxWidth( bhBgnd ), nMaxC ) )
BoxShow( bhBgnd )
FillBox( bhBgnd, cMessage )

BoxTop( bhMenu, MIN( BoxTop( bhMenu ), MAX( BoxBottom( bhArea ) - BoxLength( bhMenu ), 0 ) ) )
BoxLeft( bhMenu, MIN( BoxLeft( bhMenu ), MAX( BoxRight( bhArea ) - BoxWidth( bhMenu ), 0 ) ) )
BoxLength( bhMenu, MIN( BoxLength( bhMenu ), nMaxR) )
BoxWidth( bhMenu, MIN( BoxWidth( bhMenu ), nMaxC ) )
BoxShow( bhMenu )

ENDCASE

END WHILE (nShell > 0)

Bye( 0, 0, MAXROW(), MAXCOL() )

IF aVmode[ 1 ] := ON
SETMODE( aVmode[2], aVmode[3] )
ENDIF aVmode

/* credits */
@ 18, 0 SAY "The Leylan Factor"
@ 19, 0 SAY "98-626 Moanalua Loop, #201"
@ 20, 0 SAY "Aiea, HI 96701-5172"

@ 21, 0 SAY "(808) 487-2230"
@ 23, 0

/* reset environment */
SET( _SET_CURSOR, xCursor )
SET( _SET_SCOREBOARD, xScoreBoard )

/* reset dos error code */
ERRORLEVEL(0)

RETURN NIL



FUNCTION ReFrame( bhBox )
LOCAL nKey, nShell, cScrn

LOCAL aFrame := { " " ,;
"ÚÄ¿³ÙÄÀ³ " ,;
"ÉÍ»º¼ÍȺ " ,;
"ÖÄ·º½ÄÓº " ,;
"Õ͸³¾ÍÔ³ " ,;
"+-+|+-+| " ,;
"******** " ,;
"þþþþþþþþ " ,;
"//////// " ,;
"\\\\\\\\ " ,;
"²²²²²²²² " ,;
"±±±±±±±± " ,;
"°°°°°°°° " }

LOCAL nFrame := ASCAN( aFrame, BoxFrame( bhBox ) )

LOCAL aMsg := { "Use the Up and Down Arrows" ,;
"to change the characters " ,;
"of the frame. " ,;
" " ,;
"Impress your neighbors and" ,;
"amaze your friends with " ,;
"the simple press of a key." }

/* say message */
BoxClear( bhBox )
BoxAsay( bhBox, 1, 1, aMsg )

nShell := 1
WHILE (nShell > 0)

nKey := INKEY(0)

DO CASE

CASE nKey == K_UP
nFrame := IF(nFrame > 1, nFrame - 1, LEN( aFrame ))
BoxFrame( bhBox, aFrame[nFrame] )

BoxReshow( bhBox, BX_FRAME )

CASE nKey == K_DOWN
nFrame := IF(nFrame < LEN( aFrame ), nFrame + 1, 1)
BoxFrame( bhBox, aFrame[nFrame] )

BoxReshow( bhBox, BX_FRAME )

CASE nKey == K_ENTER
nShell := 0

CASE nKey == K_ESC
nShell := 0

ENDCASE

END WHILE (nShell > 0)

/* clear message */
BoxClear( bhBox )

RETURN NIL



FUNCTION ReTitle( bhBox, lColor )
LOCAL cColor, bhDialog, xCursor, cTitle

cColor := IF( lColor, "+W/R,,,,", "+W/W,,,," )
bhDialog := BoxNew( 20, 2, 3, 70, cColor, 1, "ÚÄ¿³ÙÄÀ³ ", " Type New Title " )

/* draw dialog */
BoxShow( bhDialog )

xCursor := SET( _SET_CURSOR, SC_NORMAL )

/* get title */
cTitle := PADR( BoxTitle( bhBox ), BoxWidth( bhDialog ) - 2, " " )
@ BoxTop( bhDialog ) + 1, BoxLeft( bhDialog ) + 1 GET cTitle
READ

SET( _SET_CURSOR, xCursor )

/* set title */
cTitle := IF( EMPTY( cTitle ), "", " " + LTRIM(RTRIM( cTitle )) + " ")
BoxTitle( bhBox, cTitle )

/* undraw dialog */
BoxUnshow( bhDialog )

/* update title */
BoxReshow( bhBox, BX_TITLE )

RETURN NIL



FUNCTION ReMessage( bhBox, lColor, cMsg )
LOCAL cColor, bhDialog, xCursor

cColor := IF(lColor, "+W/R,,,,", "+W/W,,,,")
bhDialog := BoxNew( 20, 2, 3, 70, cColor, 1, "ÚÄ¿³ÙÄÀ³ ", " Type New Message ")

/* draw dialog */
BoxShow(bhDialog)

xCursor := SET( _SET_CURSOR, SC_NORMAL )

/* get message */
cMsg := PADR( cMsg, BoxWidth( bhDialog ) - 2, " " )
@ BoxTop( bhDialog ) + 1, BoxLeft( bhDialog ) + 1 GET cMsg
READ

SET( _SET_CURSOR, xCursor )

/* set message */
cMsg := IF( EMPTY( cMsg ), " ", RTRIM( cMsg ))

/* undraw dialog */
BoxUnshow( bhDialog )

RETURN cMsg



FUNCTION FillBox( bhBox, cMsg )
LOCAL cStr, nOff, nRow, xColor
LOCAL nTop := BoxTop( bhBox )
LOCAL nBottom := BoxBottom( bhBox )
LOCAL nLeft := BoxLeft( bhBox )
LOCAL nWidth := BoxWidth( bhBox )

/* setup message */
cStr := REPL( cMsg, ROUND( (80 / LEN( cMsg ) ) + .5, 0) + 1 )
nOff := 1

xColor := SETCOLOR( BoxColor( bhBox ) )

/* fill screen */
FOR nRow := nTop TO nBottom
@ nRow, nLeft SAY LEFT( SUBS( cStr, nOff, 80 ), nWidth )
nOff := IF(nOff < LEN( cMsg ), nOff + 1, 1)
NEXT nRow

SETCOLOR( xColor )

RETURN NIL



FUNCTION ShowMem( bhBox, nType )
LOCAL cTitle

cTitle := BoxTitle( bhBox, " " + LTRIM(STR( MEMORY( nType ) )) + " K Free ... Any Key ")
BoxReshow( bhBox, BX_TITLE )

AEVAL( { 300, 600, 300 }, {| nPitch | TONE( nPitch, 1 ) } )
INKEY(0)

BoxTitle( bhBox, cTitle )
BoxReshow( bhBox, BX_TITLE )

RETURN NIL



FUNCTION Bye( nMinR, nMinC, nMaxR, nMaxC)

LOCAL nT1 := nMinR
LOCAL nT2 := ((nMaxR / 2) + 1)

LOCAL nL1 := nMinC
LOCAL nL2 := (((nMaxC + 1) / 2) + 4)

LOCAL nH := ((nMaxR / 2) - 1)
LOCAL nW := (((nMaxC + 1) / 2) - 4)

LOCAL nB1 := nT1 + nH
LOCAL nB2 := nT2 + nH

LOCAL nR1 := nL1 + nW
LOCAL nR2 := nL2 + nW - 1

LOCAL aQ := { { nT1, nL1, nB1, nR1, nT1 + 1, nL1 + 4, nB1 + 1, nR1 + 4, "" } ,;
{ nT2, nL1, nB2, nR1, nT2 - 1, nL1 + 4, nB2 - 1, nR1 + 4, "" } ,;
{ nT1, nL2, nB1, nR2, nT1 + 1, nL2 - 4, nB1 + 1, nR2 - 4, "" } ,;
{ nT2, nL2, nB2, nR2, nT2 - 1, nL2 - 4, nB2 - 1, nR2 - 4, "" } }

LOCAL nCnt, nQ

FOR nCnt := 1 TO (nMaxR / 2)

FOR nQ := 1 TO 4
aQ[nQ, 9] := SAVESCREEN( aQ[nQ, 1], aQ[nQ, 2], aQ[nQ, 3], aQ[nQ, 4] )
NEXT nQ

IF nCnt == 1
SCROLL( nT1, nL1, nB2, nR2, 0 )
ENDIF

FOR nQ := 1 TO 4
RESTSCREEN( aQ[nQ, 5], aQ[nQ, 6], aQ[nQ, 7], aQ[nQ, 8], aQ[nQ, 9] )
NEXT nQ

NEXT nCnt

RETURN NIL