Liren Large Software Subsidy 5/05.iso/a/a070/3.ddi/FOXPRO/DEMO/DEMO.PRG

Text File | 1990-05-04 | 18.1 KB | 771 lines

********************************************************
* DEMO - Self running demonstration of FoxPro features *
********************************************************

* Do some cleanup and initialization

ON ERROR DO abort
DO cleanup                    && Close everything
DIMENSION setopts[20]        && Need this array to save SET values
DO setenv                    && Save environment and SET options
DO startscreen                && Show startup screen
DO checkfiles                && Make sure data files are present

* Open driving database

SELECT 24
USE driver
INDEX ON stepno TO driver
INDEX ON stepno TO dmenu FOR stepno - INT(stepno) = 0
SET INDEX TO dmenu, driver
USE buttons IN 25
SET RELATION TO 1 INTO 25

* Create color schemes

SET COLOR OF SCHEME 12 TO SCHEME 5
cp1 = SCHEME(12,1) + ","
myscheme = ",,," + cp1 + cp1
SET COLOR OF SCHEME 12 TO &myscheme

SET COLOR OF SCHEME 13 TO SCHEME 8
cp1 = SCHEME(13,1)
cp2    = SUBSTR(cp1, AT("/", cp1) + 1)
cp3 = cp2 + "/" + cp2 + ","
cp2 = SCHEME(13,2) + ","
cp1 = cp1 + ","
myscheme = cp1 + cp2 + cp3 + cp1 + cp1 + cp2 + cp1
SET COLOR OF SCHEME 13 TO &myscheme

cp3 = SCHEME(8,6)

* Create Windows

DEFINE WINDOW frame FROM 3,3 TO 21,76 DOUBLE COLOR &cp3 SHADOW
DEFINE WINDOW demo FROM 4,40 TO 16,74 DOUBLE COLOR SCHEME 12 TITLE "═" SHADOW
DEFINE WINDOW mbrowse FROM 4,45 TO 19,73 COLOR SCHEME 13 ;
         NONE CLOSE SHADOW TITLE " "
DEFINE WINDOW btn1 FROM 4,5 TO 7,20 COLOR SCHEME 13 ;
        PANEL CLOSE SHADOW TITLE " "
DEFINE WINDOW btn2 FROM 4,25 TO 7,40 COLOR SCHEME 13 ;
        PANEL CLOSE SHADOW TITLE " "
DEFINE WINDOW btn3 FROM 10,5 TO 13,20 COLOR SCHEME 13 ;
        PANEL CLOSE SHADOW TITLE " "
DEFINE WINDOW btn4 FROM 10,25 TO 13,40 COLOR SCHEME 13 ;
        PANEL CLOSE SHADOW TITLE " "
DEFINE WINDOW btn5 FROM 16,5 TO 19,20 COLOR SCHEME 13 ;
        PANEL CLOSE SHADOW TITLE " "
DEFINE WINDOW btn6 FROM 16,25 TO 19,40 COLOR SCHEME 13 ;
        PANEL CLOSE SHADOW TITLE " "
STORE 0 TO timelimit, lastclick

* Save locations of "buttons" (to test for mouse clicks)

DIMENSION wlims[7,4]

FOR i = 1 TO 6
    this_wind = "btn"+CHR(i + 48)
    wlims[i,1] = WLROW(this_wind)
    wlims[i,2] = WLCOL(this_wind)
    wlims[i,3] = wlims[i,1] + WROWS(this_wind) + 1
    wlims[i,4] = wlims[i,2] + WCOLS(this_wind) + 1
ENDFOR
wlims[7,1] = WLROW('mbrowse')
wlims[7,2] = WLCOL('mbrowse')
wlims[7,3] = wlims[7,1] + WROWS('mbrowse') + 1
wlims[7,4] = wlims[7,2] + WCOLS('mbrowse') + 1

* Let the "menu" take control

DO WHILE .T.
    DO sethotkeys
    ON KEY LABEL MOUSE DO mousehit
    ON KEY LABEL ENTER KEYBOARD CHR(23)
    DEFINE WINDOW frame FROM 3,3 TO 21,76 DOUBLE COLOR &cp3 SHADOW
    SHOW WINDOW frame
    MODIFY MEMO buttons->b1 NOEDIT NOWAIT WINDOW btn1
    MODIFY MEMO buttons->b2 NOEDIT NOWAIT WINDOW btn2
    MODIFY MEMO buttons->b3 NOEDIT NOWAIT WINDOW btn3
    MODIFY MEMO buttons->b4 NOEDIT NOWAIT WINDOW btn4
    MODIFY MEMO buttons->b5 NOEDIT NOWAIT WINDOW btn5
    MODIFY MEMO buttons->b6 NOEDIT NOWAIT WINDOW btn6
    BROWSE FIELDS check:h=" ", topic:h="    FoxPro Topics" NOMODIFY ;
            NOMENU NOAPPEND NODELETE WINDOW mbrowse FREEZE topic TIMEOUT 30
    DEACTIVATE WINDOW mbrowse
    CLOSE MEMO buttons->b1
    CLOSE MEMO buttons->b2
    CLOSE MEMO buttons->b3
    CLOSE MEMO buttons->b4
    CLOSE MEMO buttons->b5
    CLOSE MEMO buttons->b6
    RELEASE WINDOW frame
    ON KEY
    IF READKEY() = 12
        EXIT
    ENDIF
    DO rundemo
ENDDO

* Cleanup and go home

DO restenv
ON ERROR
DO cleanup
RETURN

****************************************************************
* RUNDEMO - This is the controlling loop for a menu selection  *
****************************************************************
PROCEDURE rundemo
SET ORDER TO 2                && Let's "see" all of the driver records
ok = .t.

GO TOP
SCAN FOR check = '√'        && Look for selected topics
    this_step = INT(driver.stepno)
    this_topic = ALLTRIM(driver.topic)
    inloop = .F.
    DO WHILE INT(driver.stepno) = this_step .AND. ok    && Process all substeps

        inloop = .T.
        STORE 0 TO cnt, counter
        RESTORE FROM MEMO driver.memvars ADDITIVE
        CLEAR MACROS
        RESTORE MACROS FROM MEMO driver.macro
        * DO the starting program

        IF LEN(startprog) <> 0
            SET MOUSE OFF
            DO &startprog
            SET MOUSE ON
        ENDIF

        * Prepare the message window

        IF cnt <> 0

            * Redefine the message window

            rrow = msgrow + msgheight + 1
            rcol = msgcol + msgwidth + 1
            DEFINE WINDOW demo FROM msgrow,msgcol TO rrow,rcol ;
                    DOUBLE COLOR SCHEME 12 SHADOW ;
                    TITLE PADC(this_topic, LEN(this_topic)+2)
        ENDIF

        * Cycle through all the micro steps

        DO WHILE ok .AND. (counter < cnt)
            counter = counter + 1
            IF counter <= cnt

                = SYS(2002)
                ontop = windname(upper(wontop()))

                * Display the message

                ACTIVATE WINDOW demo
                CLEAR
                ?? msg[counter] FUNCTION "v"+ALLTRIM(STR(WCOLS()-2)) AT 1
                WAIT "" TIMEOUT OCCURS(' ', msg[counter])/4 + 1

                * Should we keep it around?

                IF .NOT. sticky
                    DEACTIVATE WINDOW demo
                ELSE
                    IF LEN(ontop) <> 0
                        SHOW WINDOW &ontop
                    ENDIF
                ENDIF

                * If ESCAPE not pressed, play the macro

                = SYS(2002, 1)
                ok = IIF(LASTKEY() = 27, .F., .T.)
                IF ok
                    CLEAR TYPEAHEAD
                    this_macro = "M"+ALLTRIM(STR(counter))
                    SET MOUSE OFF
                    PLAY MACRO &this_macro
                    SUSPEND
                    CLEAR TYPEAHEAD
                    SET MOUSE ON
                ENDIF
            ENDIF
        ENDDO

        * DO the ending program

        IF LEN(endprog) <> 0
            SET MOUSE OFF
            DO &endprog
            SET MOUSE ON
        ENDIF

        SKIP                    && Get another substep for this topic
    ENDDO                        && Finished a topic
    IF inloop
        SKIP -1
        DEACTIVATE WINDOW demo
        IF .NOT. ok
            EXIT
        ENDIF
    ENDIF
ENDSCAN

GO TOP
SET ORDER TO 1            && Let's "see" only the main steps

DO WHILE .T.
    ontop = windname(UPPER(WONTOP()))
    IF ontop <> 'SCREEN'
        RELEASE WINDOW &ontop
    ELSE
        EXIT
    ENDIF
ENDDO
RETURN

*************************************************
* CLEANUP - Close everything down                *
*************************************************

PROCEDURE cleanup
CLEAR MACROS
CLEAR ALL
CLEAR
ON KEY
RETURN

******************************************
* ABORT - Error occurred: Just shut down *
******************************************
PROCEDURE abort
ON ERROR
CLEAR TYPEAHEAD
CLEAR MEMORY            && Just in case error is insufficient memory
DO CASE
CASE ERROR() = 1
    errmsg = "Unable to find all of the demo files."
CASE ERROR() = 43 .OR. ERROR() = 0
    errmsg = "Insufficient memory to operate FoxPro demo."
OTHERWISE
    errmsg = MESSAGE()
ENDCASE
WAIT errmsg WINDOW TIMEOUT 10
DO cleanup
QUIT

*************************************************
* SETENV - Set the environment for the demo        *
*************************************************

PROCEDURE setenv
IF SET("TALK") = "ON"
    SET TALK OFF
    setopts[1] = "ON"
ELSE
    setopts[1] = "OFF"
ENDIF
setopts[2] = SET("SAFETY")
setopts[3] = SET("ECHO")
setopts[4] = SET("DEBUG")
setopts[5] = SET("NOTIFY")
setopts[6] = SET("RESOURCE")
setopts[7] = SET("RESOURCE", 1)
setopts[8] = SET("ESCAPE")
setopts[9] = SET("COMPATIBLE")
setopts[10] = _wrap

SET SAFETY OFF
SET ECHO OFF
SET DEBUG OFF
SET NOTIFY OFF
SET RESOURCE OFF
SET RESOURCE TO demo
SET ESCAPE OFF
SET COMPATIBLE OFF
_wrap = .F.
SAVE MACROS TO demo
KEYBOARD "RESUME"+CHR(13)
SUSPEND                && Make sure that command window is created
HIDE WINDOW ALL
RETURN

*************************************************
* RESTENV - Restore the original environment    *
*************************************************

PROCEDURE restenv
SET RESOURCE OFF
USE demo IN 24
PACK
USE
SET SAFETY &setopts[2]
SET ECHO &setopts[3]
SET DEBUG &setopts[4]
SET NOTIFY &setopts[5]
SET RESOURCE TO &setopts[7]
SET RESOURCE &setopts[6]
SET ESCAPE &setopts[8]
SET COMPATIBLE &setopts[9]
_wrap = setopts[10]
SET TALK &setopts[1]
RESTORE MACROS FROM demo
RETURN

*****************************************************
* STARTSCREEN - Show startup screen                    *
*****************************************************

PROCEDURE startscreen
DEFINE WINDOW SCREEN FROM 0,0 TO 24,79 NONE CLOSE COLOR SCHEME 1
ACTIVATE WINDOW SCREEN
TEXT



 ▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀                    ▀▀▀▀▀▀▀▀▀▀▀
   ▀▀         ▀▀▀                      ▀▀       ▀▀
   ▀▀           ▀                      ▀▀        ▀▀
   ▀▀                                  ▀▀        ▀▀
   ▀▀          ▀▀▀      ▀▀▀▀▀  ▀▀▀▀▀   ▀▀       ▀▀  ▀▀▀   ▀▀▀▀         ▀▀▀
   ▀▀▀▀▀    ▀▀     ▀▀     ▀▀    ▀▀     ▀▀▀▀▀▀▀▀▀      ▀▀ ▀▀   ▀▀    ▀▀     ▀▀
   ▀▀      ▀▀       ▀▀     ▀▀  ▀▀      ▀▀             ▀▀▀          ▀▀       ▀▀
   ▀▀     ▀▀         ▀▀     ▀▀▀        ▀▀             ▀▀          ▀▀         ▀▀
   ▀▀      ▀▀       ▀▀     ▀▀ ▀▀       ▀▀             ▀▀           ▀▀       ▀▀
   ▀▀       ▀▀     ▀▀     ▀▀   ▀▀      ▀▀             ▀▀            ▀▀     ▀▀
 ▀▀▀▀▀▀▀       ▀▀▀      ▀▀▀▀▀  ▀▀▀▀  ▀▀▀▀▀▀         ▀▀▀▀▀▀             ▀▀▀
ENDTEXT
? PADC(VERSION()+' (c) Fox Software 1989,1990, Serial # '+SYS(9), 79)
RETURN

*************************************
* MOUSEHIT - Mouse click handler    *
*************************************
PROCEDURE mousehit

* See if it's outside the browse window

myrow = mrow("SCREEN")
mycol = mcol("SCREEN")
FOR i = 1 TO 6
    IF myrow >= wlims[i,1] .AND. myrow <= wlims[i,3] .AND. ;
       mycol >= wlims[i,2] .AND. mycol <= wlims[i,4]
        EXIT
    ENDIF
ENDFOR

IF i <> 7
    = INKEY("M")                && Get rid of mouse event
    timelimit = 0
ENDIF

DO CASE
CASE i = 1                        && Demo help screen
    DO demohelp
CASE i = 2                        && "Select/Deselect" button
    DO checkit
CASE i = 3                        && "Check None"
    DO checknone
CASE i = 4                        && "See Demo" button
    KEYBOARD CHR(13)
CASE i = 5                        && "Check All"
    DO checkall
CASE i = 6                        && "Exit Demo" button
    KEYBOARD CHR(27)
CASE i = 7                        && "Topics menu"
    IF SECONDS() <= timelimit .AND. lastclick = myrow     && Must be a double click
        = INKEY("M")            && Get rid of the event
        DO checkit
        timelimit = 0
    ELSE                            && Start anew
        timelimit = SECONDS() + _DBLCLICK
        lastclick = myrow
    ENDIF
ENDCASE
RETURN

*************************************
* CHECKIT - Select/Deselect a topic    *
*************************************
PROCEDURE checkit
DO clearhotkeys
REPLACE check WITH IIF(check = '√', ' ', '√')
SKIP 1
SKIP -1
DO sethotkeys
RETURN

*************************************
* CHECKNONE - Deselect all topics    *
*************************************
PROCEDURE checknone
DO clearhotkeys
saverec = RECNO()
REPLACE ALL check WITH ' ' FOR stepno - INT(stepno) = 0 WHILE stepno < 90
GOTO saverec
DO sethotkeys
RETURN

*********************************
* CHECKALL - Select all topics    *
*********************************
PROCEDURE checkall
DO clearhotkeys
saverec = RECNO()
REPLACE ALL check WITH '√' FOR stepno - INT(stepno) = 0 WHILE stepno < 90
GOTO saverec
DO sethotkeys
RETURN

*************************************************************
* WINDNAME - Make window name valid for use in a command    *
*************************************************************
FUNCTION windname
PARAMETER ontop
n = LEN(ontop)
FOR i = 1 TO n
    c = SUBSTR(ontop,i,1)
    IF c < 'A' .OR. c > 'Z'
        EXIT
    ENDIF
ENDFOR
RETURN LEFT(ontop, i - 1)

*************************************************************
* CHECKFILES - Make sure all necessary files are present    *
*************************************************************
PROCEDURE checkfiles
USE custdemo
INDEX ON cust_id TO cus_id
USE paydemo
INDEX ON cust_id TO pay_cus
USE helpdemo
USE
RETURN

*************************************************
* DEMOHELP - A little help on running the demo    *
*************************************************
PROCEDURE demohelp
DO clearhotkeys
DEFINE WINDOW demo FROM 2,3 TO 22,76 DOUBLE COLOR SCHEME 12 TITLE " About the FoxPro Demo " SHADOW
ACTIVATE WINDOW demo
TEXT
    This self running FoxPro demo program is written entirely in
    FoxPro.  It combines the use of standard commands and functions
    with the keyboard macro facility.  See DEMO.PRG and DRIVER.DBF.

    To Select/Deselect topics:   Double click on Topic, or
                                 Press the SPACEBAR, or
                                 Click the Select button, or
                                 Click the Select None button, or
                                 Click the Select All button

    To see topics demonstrated:  Press ENTER, or
                                 Click the See Demo button

    To exit the demo program:    Press ESCAPE, or
                                 Click the Exit button

    To interrupt demonstration:  Press ESCAPE at any explanatory note
ENDTEXT

= INKEY(0, 'MH')
DEFINE WINDOW demo FROM 4,40 TO 16,74 DOUBLE COLOR SCHEME 12 TITLE "═" SHADOW
DO sethotkeys
RETURN

********************************************
* SETHOTKEYS - Define some of the hot keys *
********************************************
PROCEDURE sethotkeys
ON KEY LABEL SPACEBAR DO checkit
ON KEY LABEL F1 DO demohelp
ON KEY LABEL F2 DO checknone
ON KEY LABEL F3 DO checkall
RETURN

**********************************************************************
* CLEARHOTKEYS - Clear hot keys to prevent calls from within hot key *
*                routines.                                           *
**********************************************************************
PROCEDURE clearhotkeys
CLEAR TYPEAHEAD
ON KEY LABEL SPACEBAR
ON KEY LABEL F1
ON KEY LABEL F2
ON KEY LABEL F3
RETURN

*************************************
* All the Start and End Programs    *
*************************************
PROCEDURE start9
CREATE VIEW demo
msg[11] = RECNO()
CLOSE ALL
helpfile = SYS(2004)+"FOXHELP"
SET HELP TO &helpfile
SELECT A
RETURN

PROCEDURE end9
helpfile = SYS(2004)+"FOXHELP"
SET HELP TO &helpfile
SELECT 24
SET VIEW TO demo
GO msg[11]
RETURN

PROCEDURE start8
SELECT A
RETURN

PROCEDURE end8
USE
SELECT 24
RETURN

PROCEDURE start7
SELECT A
USE custdemo
SET FIELDS TO cust_id, company, address1, city, state, zip
RETURN

PROCEDURE end7
USE
SET FIELDS OFF
SELECT 24
RETURN

PROCEDURE start6
SELECT A
USE custdemo
RETURN

PROCEDURE end6
USE
SELECT 24
RETURN

PROCEDURE start5
CREATE VIEW demo
msg[11] = RECNO()
CLOSE ALL
SELECT A
RETURN

PROCEDURE start4
SET DEBUG ON
RETURN

PROCEDURE end4
IF .NOT. ok                && ESCAPE was pressed
    SET DEBUG OFF
    RETURN
ENDIF

DECLARE a[10]
SET TALK OFF
* Fill an array with random numbers
FOR i = 1 TO 10
    a[i] = RAND() * 100
NEXT
* Sort the numbers with a Bubble Sort.
next2last = 9
sorted = .f.
DO WHILE !sorted        && Keep making passes until
                        && the array is sorted.
    sorted = .t.        && Assume the best.
    FOR probe = 1 to next2last
                        && swap out of order items
        IF (a[probe] > a[probe+1])
            temp = a[probe+1]
            a[probe+1] = a[probe]
            a[probe] = temp
            sorted = .f.    && and make AT LEAST
                            && one more pass
        ENDIF
    NEXT
    next2last = next2last - 1
ENDDO
SET DEBUG OFF
RETURN

PROCEDURE start3
COPY FILE demo.prg TO mydemo.prg
RETURN

PROCEDURE end3
ontop = windname(UPPER(WONTOP()))
IF ontop = "MYDEMO"
    RELEASE WINDOW &ontop
ENDIF
DELETE FILE mydemo.prg
RETURN

PROCEDURE start2
SELECT A
USE custdemo
GO 43
REPLACE company WITH "Forest Dry Cleaning"
GO 31
REPLACE contact WITH "Melissa Thompson", comments WITH ""
BROW WIDTH 28 NOWAIT NORMAL
RETURN

PROCEDURE end2
USE
SELECT 24
RETURN

PROCEDURE start1
CREATE VIEW demo
msg[11] = RECNO()
CLOSE ALL
SELECT A
RETURN

PROCEDURE end1
SET VIEW TO demo
GO msg[11]
RETURN

PROCEDURE start0_2
SET DEBUG ON
SELECT A
USE custdemo
RETURN

PROCEDURE end0_2
SET DEBUG OFF
USE
SELECT 24
DO startscreen
RETURN

PROCEDURE start0_1
SELECT A
RETURN

PROCEDURE end0_1
USE
SELECT B
USE
SELECT 24
RETURN

PROCEDURE start0
statline ="Command Line     │< :>│                       │                   │Ins   │      "
statline = STUFF(statline, 20, 1, LEFT(SYS(5),1))
oldcolor = SET("COLOR")
SET COLOR TO W/N, N/W
CLEAR
@ 24,0 say PADC("Enter a command", 80)
@ 22,0 GET statline
CLEAR GETS
@ 20,0 SAY ". TYPE question.txt"
WAIT "** What would you wish for in the ULTIMATE microcomputer database system? **" TIMEOUT 5
SET COLOR TO &oldcolor
CLEAR
SELECT A
USE custdemo
USE paydemo INDEX pay_cus IN B
SET RELATION TO cust_id INTO B
RETURN

PROCEDURE end0
IF .NOT. ok
    SELECT 24
    RETURN
ENDIF

DIMENSION wpos(200,2)
hd = 7
vd = 2
n = 0
k = 0
clear
ok = .t.
ON ERROR ok = .f.
for i = 1 to 24 step vd
    for j = 1 to 75 step hd
        n = n + 1
        name = "W"+alltrim(str(n))
        wpos(n,1) = i
        wpos(n,2) = j+k
        do case
        case mod(n,4)=0
            defi windo &name from i,j+k to i+4,j+k+5 color scheme mod(n,11)+1 ;
                float grow zoom close shadow " "," "," "," ",;
                chr(254),chr(240)," ",chr(249)," "," "," "," "," "," "," "," "
        case mod(n,4)=1
            defi windo &name from i,j+k to i+4,j+k+5 color scheme mod(n,11)+1 ;
                float grow zoom close shadow
        case mod(n,4)=2
            defi windo &name from i,j+k to i+4,j+k+5 color scheme mod(n,11)+1 ;
                float grow zoom close shadow double
        case mod(n,4)=3
            defi windo &name from i,j+k to i+4,j+k+5 color scheme mod(n,11)+1 ;
                float grow zoom close shadow "═","═","║","║",;
                "╔","╗","╚","╝","═","═","│","│","╒","╕","╘","╛"
        endcase
        IF .NOT. ok
            n = n - 1
            EXIT
        ENDIF
        acti windo &name
        ?? "Fox"
        ? "Pro"
        ? str(n,3)
    endfor
    IF .NOT. ok
        EXIT
    ENDIF
    k = k + 2
    if k > 8
        k = 0
    endif
endfor
ON ERROR DO abort
do hidewind

for i = 1 to n
    name = "W"+alltrim(str(i))
    activate window &name
    hide window &name
endfor
do showwind
do closewind

SELECT 24
return

procedure closewind
for i = n to 1 step -1
    name = "W"+alltrim(str(i))
    release window &name
endfor
return

procedure hidewind
for i = 1 to n
    name = "W"+alltrim(str(i))
    hide window &name
endfor
return

procedure showwind
for i = 1 to n
    name = "W"+alltrim(str(i))
    show window &name
endfor
return