Software Du Jour

home *** CD-ROM | disk | FTP | other *** search

/ Software Du Jour / SoftwareDuJour.iso / BUSINESS / DBASE / DBAPG.ARC / VARIOUS.ALG < prev next >

Wrap

Text File | 1985-01-11 | 26.0 KB | 857 lines

* Program..: VARIOUS.ALG * Notice...: Copyright 1983 & 1984, Ashton-Tate, All Rights Reserved * Notes....: These are six of the longer algorithms in the book. * * THIS FILE WILL NOT EXECUTE PROPERLY AS IT STANDS * BECAUSE EACH ALGORITHM IS A SEPARATE ENTITY WRITTEN * TO RUN UNDER A PARTICULAR VERSION OF dBASE. * * THESE ALGORITHMS MAY NEED REVISION TO RUN PROPERLY * BECAUSE SOME USE METAVARIABLES THAT MUST BE REPLACED * WITH VALUES APPROPRIATE TO YOUR APPLICATION. * * The algorithms included are: * * 1. Binary Locate, chapter 19, page 335 * 2. Check for Duplicates, chapter 19, page 337 * 3. Color Demo, chapter 18, page 273 * 4. Datetest, chapter 22, page 395 * 5. Multiple Screens, chapter 19, page 348 * 6. Prompt Pad, chapter 18, page 288 * 7. Page Counter, chapter 21, page 384 * 8. Periodic Files, chapter 19, page 302 * 9. Pseudo Arrays, chapter 17, page 239 * 10. Quick Date Trap, chapter 16, page 215 ********************************************************************** * Binary Locate: * * LOCATING.PRG [II] * * A binary search to replace the LOCATE command * when the key is in sequential order... * * is:found ::= .T. if a match occurs, current record is match. * is:found ::= .F. if no match, current record varies. * * Establish working environment... ERASE SET TALK OFF STORE F TO is:found * * Prompt operator for details of the search... ACCEPT "Enter file name -->" TO file:name ACCEPT "Enter field name -->" TO field:name INPUT "Enter data to find -->" TO search:key * Note that the INPUT command requires character type data to be delimited. * * Open the file... USE &file:name * * Branch for first or last records... IF &field:name = search:key * * Found: it's the first record. STORE T TO is:found ELSE * Maybe it's the last record... GO BOTTOM IF &field:name = search:key * * Found: it's the last record. STORE T TO is:found ELSE * Not there either, so let's search. * Set the top, middle, and bottom markers... STORE # TO high STORE 0 TO mid STORE 1 TO low * * Establish a loop for repitition... DO WHILE .NOT. is:found * * Branch to end search if record does not exist... IF mid = low + INT((high-low)/2) SET TALK ON RELEASE file:name, search:key, field:name, low, mid, high RETURN ELSE * * Set new middle marker; see where to go next... STORE low + INT((high-low)/2) TO mid GO mid DO CASE CASE &field:name > search:key * * Field value is high, so set next block * to lower half of existing block... STORE mid TO high CASE &field:name < search:key * * Field value is low, so set next block * to upper half of existing block... STORE mid TO low OTHERWISE * * Found it... STORE T TO is:found ENDCASE ENDIF [record does not exist] ENDDO [WHILE .NOT. found] ENDIF [last record] ENDIF [first record] RELEASE file:name, search:key, field:name, low, mid, high RETURN * EOF: Locating.prg ********************************************************************** * Check for Duplicates: * * dBASE III... * memvar = SPACE(6) DO WHILE .T. * Prompt for an entry from the operator... @ <coordinates> GET memvar PICTURE [AA9999] READ CLEAR GETS @ <coordinates> SAY "Please be patient while I check for duplicates." * * Save the current record number in order to return after searching... record_no = RECNO() * * Search for the entry, and test for a find... SEEK memvar IF .NOT. EOF() ? "This already exists, please re-enter..." ELSE * * Restore record pointer to previous position, and exit the loop... GO record_no EXIT ENDIF * * Restore record pointer to previous position... GO record_no ENDDO * dBASE II... * STORE " " TO memvar STORE T TO condition DO WHILE condition * Prompt for an entry from the operator... @ <coordinates> GET memvar PICTURE [AA9999] READ CLEAR GETS @ <coordinates> SAY "Please be patient while I check for duplicates." * * Save the current record number in order to return after searching... STORE # TO record:no * * Search for the entry, and test for a find... FIND &memvar IF # > 0 ? "This already exists, please re-enter..." ELSE * Change the <condition> to exit the loop... STORE F TO condition ENDIF * * Restore record pointer to previous position... GO record:no ENDDO ********************************************************************** * Color Demo: * * COLORS.PRG [II] * SET TALK OFF ERASE * STORE ' VIDEO FOR "SAYS" =' TO text1 STORE ' VIDEO FOR "GETS" =' TO text2 STORE 0 TO line STORE 1 TO n1 * DO WHILE n1 < 255 STORE text1 + STR(n1,3) + ' ' TO text1 STORE 1 TO n2 DO WHILE n2 < 255 STORE $(text2,1,19) + STR(n2,3) + ' ' TO text2 SET COLOR TO n2,n1 IF line > 22 ERASE STORE 0 TO line ENDIF @ line,12 SAY text1 @ line,38 GET text2 STORE line + 1 TO line STORE n2 + 1 TO n2 ENDDO STORE n1 + 1 TO n1 ENDDO SET TALK ON RETURN * EOF: Colors.prg ********************************************************************** * Datetest: ; DATETEST.A86 ; Date test subroutine for use in dBASE-II/86 2.4 ; ; Assemble with ASM86 under CP/M-86. ; The DATETEST.H86 file can be LOADed from dBASE II. ; POKE the decimal date values to be checked before calling: ; POKE month at 57501 ; POKE day at 57502, and ; POKE year at 57503 ; SET CALL TO 57504 ; Then CALL to execute this routine ; ; ORG 57501 MONTH DB 0 ; MONTH PARAMETER. DAY DB 0 ; DAY YEAR DB 0 ; YEAR ORG 57504 ; 4 BYTES ABOVE 'TOP' OF ; dBASE II 2.4 (57500d) THIS ; KEEPS CODE ABOVE MM/DD/YY BUFFERS START: ; ; CHECK FOR 0 <= YEAR <= 99. ; MOV AL,BYTE PTR YEAR ; YEAR TO AL REGISTER OR AL,AL ; IS IT < 1 ? JZ ERROR ; YES, ERROR CMP AL,100 ; IS IT >= 99 ? JGE ERROR ; YES, ERROR ; ; CHECK FOR 1 <= MONTH <= 12. ; MOV AH,0 MOV AL,BYTE PTR MONTH ; MONTH TO AL REGISTER OR AL,AL ; IS IT < 1 ? JZ ERROR ; YES, ERROR CMP AL,12 ; IS IT >= 12 ? JGE ERROR ; YES, ERROR ; ; TEST DAYS IN MONTH. ; MOV BX,OFFSET DTABLE-1 ; POINT BX TO DAY-IN-MONTH ; TABLE ADD BX,AX ; POINT TO NUMBER OF DAYS FOR ; MONTH MOV AH,BYTE PTR [BX] ; ... FETCH VALUE MOV AL,BYTE PTR DAY ; PICK UP DAY OR AL,AL ; 0 < DAY <= [DTABLE-1+MONTH] JE ERROR CMP AH,28 ; FEBRUARY? JNE NOTLEAP ; JUMP IF NOT FEBRUARY. PUSH AX MOV AL,BYTE PTR YEAR ; AND AL,3 ; CHECK IF YEAR IS DIVISIBLE ; BY 4 POP AX JNE NOTLEAP ; JUMP IF NOT LEAP YEAR. INC AH ; LEAP YEAR; SET DAYS/MONTH ; TO 29 NOTLEAP: CMP AL,AH ; EXCEEDS DAYS/MONTH? JG ERROR ; IF SO, ERROR RET ; OTHERWISE, IT IS A GOOD DATE ; ; SET MONTH, DAY, AND YEAR TO NULLS IF ERROR IN DATE. ; ERROR: MOV BYTE PTR MONTH,0 ; ZERO OUT MONTH MOV WORD PTR DAY,0 ; ZERO OUT DAY AND YEAR RET ; RETURN TO dBASE II ;;; Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec DTABLE DB 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 END * DATETEST.PRG * Demonstrates the use of DATETEST.H86 * If the date is not valid the memory locations 57501, * 57502, and 57503 will contain zeros. * SET TALK OFF STORE 0 TO mmonth,mday,myear * LOAD DATETEST.H86 SET CALL TO 57504 * ERASE @ 10,10 SAY 'ENTER MONTH' GET mmonth PICTURE '99' @ 12,10 SAY 'ENTER DAY' GET mday PICTURE '99' @ 14,10 SAY 'ENTER YEAR' GET myear PICTURE '99' READ * POKE 57501, mmonth, mday, myear * * ---Display the values before and after the CALL. ? PEEK( 57501 ), PEEK( 57502 ), PEEK( 57503 ) CALL ? PEEK( 57501 ), PEEK( 57502 ), PEEK( 57503 ) * IF PEEK( 57501 ) = 0 ? "INVALID DATE" ENDIF * CLEAR SET TALK ON RETURN * EOF: DATETEST.PRG ********************************************************************** * Multiple Screens: * * Multiple screen routine [II, 2.4x] * DO WHILE T * * Prompt the operator for a key expression to find... <Do a subroutine for this entry> * * Find the first occurrence of a particular key... FIND &m:key * * Branch for no find... IF # = 0 STORE ' ' TO t:waiting @ 22,23 SAY "There are no records for this key." @ 23,24 SAY "Press any key to continue..." GET t:waiting READ NOUPDATE CLEAR GETS RETURN ELSE STORE T TO t:is:found ENDIF * * Display headings for the output... @ 6, 8 SAY "Key:" @ 6,30 SAY "Address:" @ 6,60 SAY "Phone Number:" * * Initialize memvars to control screens... * String of possible menu items (12 per screen)... STORE 'ABCDEFGHIJKL' TO t:menu:str * Line counter initialized for first item... STORE 8 TO t:line * Used as parameter in substring function to get * menu item from string of possibilities... STORE 1 TO t:menu:num * Possible choices in operator entry trapping routine... STORE ' ?' + $(t:menu:str,t:menu:num,1) TO t:selectns * Screen number used as macro in memvar array of record numbers... STORE '11' TO t:scrn:no * Number of the first record on this screen is used to * reposition record pointer when changing screens... STORE # TO t:record&t:scrn:no * * A loop for each record on the screen... DO WHILE t:is:found * Save the menu letter for this record... STORE $(t:menu:str,t:menu:num,1) TO t:menu:ltr * Save current record number in a memvar using the * current menu letter in the memvar name. This is used * to postion the record pointer to a record selected by * menu letter. STORE # TO t:menu:&t:menu:ltr * * Display the menu letter and pointer... @ t:line, 2 SAY t:menu:ltr @ t:line, 4 SAY "-->" * * Display data from the current record... @ t:line, 8 SAY Key @ t:line,30 SAY Address @ t:line,60 SAY Telephone * * Next record, and increment display line... SKIP STORE t:line + 1 TO t:line * * Branch for another menu item... IF .NOT. ( t:menu:num = 12 .OR. EOF .OR. (.NOT. m:key = Key) ) STORE t:menu:num + 1 TO t:menu:num STORE t:selectns + $(t:menu:str,t:menu:num,1) TO t:selectns LOOP * ELSE * Branch for another screen, eof, or end of this key data... DO CASE * CASE t:scrn:no = '11' .AND. ( (m:key # Key) .OR. EOF ) * No more records, only one screen... @ 21, 0 SAY "There are NO more records for this key." @ 22, 0 SAY "Select a record by letter," * CASE m:key = Key .AND. t:scrn:no = '11' .AND. (.NOT. EOF) * More records, still on first screen... @ 21, 0 SAY "MORE records for this key on the NEXT screen." @ 22, 0 SAY "Select a record by letter, N = NEXT screen," STORE t:selectns + 'N' TO t:selectns * CASE VAL(t:scrn:no) > 11 .AND. ( (m:key # Key) .OR. EOF ) * No more records, more than one screen... @ 21, 0 SAY "MORE records for this key on the PREVIOUS screen." @ 22, 0 SAY "Select a record by letter, P = PREVIOUS screen," STORE t:selectns + 'P' TO t:selectns * CASE m:key = Key .AND. VAL(t:scrn:no) > 11 .AND. (.NOT. EOF) * More records, more than one screen... @ 21, 0 SAY "MORE records for this key " +; "on both the PREVIOUS and NEXT screens." @ 22, 0 SAY "Select a record by letter, "+; "N = NEXT screen, P = PREVIOUS screen," STORE t:selectns + 'NP' TO t:selectns ENDCASE * * Display the last line in the prompt... @ 23, 0 SAY "SPACE = another customer, RETURN = Main Menu..." * * Get the operator's selection... STORE '\' TO t:select DO WHILE .NOT. t:select $ t:selectns STORE '?' TO t:select @ 23,47 GET t:select PICTURE '!' READ NOUPDATE CLEAR GETS ENDDO * * Branch for selection... DO CASE CASE t:select = '?' * Restore environment and exit... RELEASE ALL LIKE t:* USE RETURN CASE t:select = ' ' * Loop around to enter another customer... STORE F TO t:is:found LOOP CASE t:select $ 'ABCDEFGHIJKL' * View or edit a displayed record... * * Position record pointer to selected record... GO t:menu:&t:select * * Clear some room in memory, and do editing routine... RELEASE ALL LIKE t:menu:* <Do a subroutine to edit the record> * * Exit the inner loop to enter another key expression... * (This is a good example of where the EXIT command * in dBASE III really speeds things up!) STORE F TO t:is:found LOOP CASE t:select = 'N' * Next screen... * Reset screen line counter... STORE 8 TO t:line * Increment screen number... STORE STR( VAL(t:scrn:no)+1 ,2) TO t:scrn:no * Save first record of this screen... STORE # TO t:record&t:scrn:no CASE t:select = 'P' * Previous screen... * Reset screen line counter... STORE 8 TO t:line * Decrement screen number... STORE STR( VAL(t:scrn:no)-1 ,2) TO t:scrn:no * Position to first record of previous screen... GO t:record&t:scrn:no ENDCASE * * Reset memvars for the next screen's menu... STORE ' ?A' TO t:selectns STORE 1 TO t:menu:num * * Clear the current screen leaving the header... @ 8,0 @ 9,0 @ 10,0 @ 11,0 @ 12,0 @ 13,0 @ 14,0 @ 15,0 @ 16,0 @ 17,0 @ 18,0 @ 19,0 @ 21,0 @ 22,0 @ 23,0 * ENDIF ENDDO [WHILE t:is:found] * * Clear the header... @ 6,0 ENDDO [WHILE T] * * End of multiple screen routine ********************************************************************** * Prompt Pad: * * Prompt-Pad Algorithm [III] * * Initialize prompts in memvar array... STORE '<prompt-1>' TO prompt_001 STORE '<prompt-2>' TO prompt_002 STORE '<prompt-3>' TO prompt_003 STORE '<prompt-4>' TO prompt_004 STORE '<prompt-5>' TO prompt_005 STORE '<prompt-6>' TO prompt_006 STORE '<prompt-7>' TO prompt_007 STORE '<prompt-8>' TO prompt_008 * * Can have as many prompts as there are available memvars. * (60 in II, 252 in III because this algorithm uses 4 memvars) * * Initialize controlling memvars with first and last numbers... STORE '001' TO first, counter STORE '008' TO last * * Display instructions to operator... @ 23,17 SAY "Press SPACE or B to change, RETURN to enter..." * * Set up loop to redisplay <prompts> until one is chosen... SET BELL OFF STORE " " TO switch DO WHILE switch # "?" * * Blank the previous display if there is one... @ 20,23 * <set screen to attribute or color that highlights the prompt> * @ 20,23 SAY prompt_&counter STORE "?" TO switch * <set screen to invisible in order to conceal the GET> * @ 23,77 GET switch PICTURE "!" READ CLEAR GETS * * Branch to increment counter and switch selection... DO CASE CASE switch = " " .AND. counter < last STORE SUBSTR( STR( &counter+1001,4 ) ,2,3) TO counter CASE switch = " " .AND. counter = last STORE first TO counter CASE switch = "B" .AND. counter > first STORE SUBSTR( STR( &counter+ 999,4 ) ,2,3) TO counter CASE switch = "B" .AND. counter = first STORE last TO counter ENDCASE ENDDO * * Restore the environment before moving on... <set screen back to normal> SET BELL ON @ 20, 0 SAY [ ] @ 23,17 * * Branch to execute selection... DO CASE CASE counter = '001' <commands> CASE counter = '002' <commands> CASE counter = '003' <commands> CASE counter = '004' <commands> CASE counter = '005' <commands> CASE counter = '006' <commands> CASE counter = '007' <commands> CASE counter = '008' <commands> ENDCASE * * EOA: Prompt-Pad ********************************************************************** * Page Counter: * * Page counter algorithm, one file. * * Initialize counters to starting values. * Start t:line high enough to take the branch for a * new heading just inside the DO loop... STORE 61 TO t:line STORE 5 TO t:col STORE 0 TO t:pagectr * * Look at each record in the file sequentially... GO TOP DO WHILE .NOT. EOF * * Branch for new page... IF t:line > 60 STORE 1 TO t:line STORE t:pagectr + 1 TO t:pagectr * * This next line causes a form-feed to be sent to the printer * because it is now a lower value than the last one sent... @ t:line ,t:col+66 SAY 'Page' + STR(t:pagectr,3) @ t:line+1,t:col+66 SAY DATE() @ t:line+4,t:col+25 SAY <heading> ENDIF * @ t:line, t:col SAY <data from this record> * * Next record, and increment the line counter... SKIP STORE t:line + 1 TO t:line ENDDO * * EOA ********************************************************************** * Periodic Files: * * dBASE II... * * Prompt for the file to use... STORE T TO select DO WHILE select STORE " " TO t:month,t:year @ 5, 9 SAY "Enter the month and year of the data you want to enter." @ 7,17 SAY "Month " GET t:month PICTURE [##] @ 7,31 SAY "<Ctrl-C> to return to main menu." @ 8,17 SAY "Year " GET t:year PICTURE [##] READ CLEAR GETS @ 10,0 * DO CASE * CASE t:month = " " .AND. t:year = " " * Branch to exit to main menu if there is no entry... RELEASE ALL LIKE t:* RETURN * CASE VAL(t:month) < 1 .OR. VAL(t:month) > 12 .OR.; VAL(t:year) < 83 .OR. VAL(t:year) > 98 * Branch to trap invalid entries... @ 10,22 SAY "Invalid entry -- please re-enter..." LOOP * CASE VAL(t:month) < 10 * Branch to format leading zero in month... STORE "0" + STR(VAL(t:month),1) TO t:month ENDCASE * * Set up filename in the format PL_<mm>-<yy> * where <mm> ::= month, and <yy> ::= year... STORE "PL_" + t:month + "-" + t:year TO t:use:file * * Verify existence of file, exit loop if file exists... IF FILE("&t:use:file") STORE F TO select ELSE * Prompt to create new file or re-enter the date... @ 10,20 SAY "I cannot find the file " + t:use:file + ".DBF." @ 12, 7 SAY "Press <C> to Create this file, " +; "or any other key to re-enter..." STORE "?" TO t:waiting @ 12,69 GET t:waiting READ CLEAR GETS @ 10, 0 @ 12, 0 * * Branch to create a new placement file... IF !(t:waiting) = "C" @ 7,31 @ 10,15 SAY "Just a moment please, while I prepare the files..." USE PL_place COPY STRUCTURE TO &t:use:file STORE F TO select ENDIF ENDIF * ENDDO [WHILE select] * * Clear the used part of the screen... @ 5,0 @ 7,0 @ 8,0 @ 10,0 @ 12,0 * * Open the file... USE &t:use:file * * EOA ********************************************************************** * Pseudo Arrays: * * AR_DEMO.PRG [III] * * Initialize a memvar to use as a counter... * A character type is used because it will be concatenated * to a memvar name to give us programming access to the array. STORE '000' TO counter * * Set up a loop for the size of the array, twelve in this * example. (Remember the limit of active memory variables) DO WHILE counter < '012' * * Increment counter by 1... STORE SUBSTR( STR( &counter+1001,4 ) ,2,3) TO counter * [In II, substitute $ for SUBSTR] * * Assign values to the array elements... STORE VAL(counter) TO number&counter STORE 'EXAMPLE ' + counter TO alpha&counter ENDDO * EOF: AR_DEMO.PRG * ARRAY.CMD [II] * * Initialize the array(s) with values... STORE "101275031020680710321417104210001051971510622000"+; "107117081081275610915281110122631111528411211763"+; "113095171140025011500575116015821170182611802929"+; "1190427612005326" TO prodtable1 STORE "121305721227086012371412124000211255179112600022"+; "127807111286572112918251130362211314825113236711"+; "133715901340520013557500136285101376281013892920"+; "1396724014062350" TO prodtable2 * * Initialize a variable for entry... STORE " " TO prod:nmbr * * Set up a loop for repetition... DO WHILE T * * Prompt for the product number... @ 5,20 SAY "Enter the product number (Return to Quit)"; GET prod:nmbr PICTURE "999" READ CLEAR GETS * * Depending on the contents of prod:nmbr, either * RETURN out of this program, LOOP back to DO WHILE T, * or select the proper table and execute the rest of * this program... DO CASE CASE prod:nmbr = " " SET TALK ON RETURN CASE prod:nmbr < "101" .OR. prod:nmbr > "140" @ 10,25 SAY "Incorrect product number " LOOP CASE prod:nmbr > "100" .AND. prod:nmbr < "121" STORE "prodtable1" TO array CASE prod:nmbr > "120" .AND. prod:nmbr < "141" STORE "prodtable2" TO array ENDCASE * * Search for the prod:nmbr... * Notice the use of the macro function to specify the array. STORE 1 TO pointer * (The macro cannot be used in a DO loop in dBASE III.) DO WHILE prod:nmbr # $(&array,pointer,3) .AND. pointer < 160 STORE pointer + 8 TO pointer ENDDO * * Display the results... STORE VAL($(&array,pointer+3,5)) / 100.00 TO prod:price @ 10,25 SAY " The price is: $" + STR(prod:price,6,2) * * Housekeeping... STORE " " TO prod:nmbr ENDDO * EOF: Array.cmd ********************************************************************** * Quick Date Trap: [II] * * Start of date entry routine... * @ <entry coordinates> GET m:date PICTURE [##/##/##] READ NOUPDATE CLEAR GETS STORE VAL($(m:date,1,2)) TO t:month STORE VAL($(m:date,4,2)) TO t:day STORE VAL($(m:date,7,2)) TO t:year DO WHILE (m:date # [ / / ]) .AND. (t:month<1 .OR. t:month>12 .OR.; t:day<1 .OR. t:day>VAL($("312931303130313130313031",(t:month-13* INT(t:month/; 13))*2-1,2)) .OR. (t:month=2 .AND. t:day>28 .AND. t:year/4.0>INT(t:year/4.0))) @ <message coordinates> SAY "Not a valid date, please re-enter..." @ <entry coordinates> GET m:date PICTURE [##/##/##] READ NOUPDATE CLEAR GETS STORE VAL($(m:date,1,2)) TO t:month STORE VAL($(m:date,4,2)) TO t:day STORE VAL($(m:date,7,2)) TO t:year @ <message coordinates> ENDDO * * Format the string if it contains a date with blank spaces... IF " " $ m:date .AND. (.NOT. m:date = [ / / ]) * * Right justify the characters in each subvariable... STORE STR(t:month,2) +"/"+ STR(t:day,2) +"/"+ STR(t:year,2) TO m:date * * Use the date function to add leading zeros... * Save the system date... STORE DATE() TO t:date * Set system date to entered date... SET DATE TO &m:date * Replace entered date with formatted system date... STORE DATE() TO m:date * Restore original system date... SET DATE TO &t:date * * Redisplay the formatted date... @ <entry coordinates> GET m:date PICTURE [##/##/##] CLEAR GETS ENDIF * * End of date entry routine. ********************************************************************** * EOF: Various.alg up a loop for the size of the array, twelve in this * example. (Remember the limit of active memory variables) DO WHILE counter < '012' * * Increment counter by 1... STORE SUBSTR( STR( &counter+1001,4 ) ,2,3) TO counter * [In II, substitute $ for SUBSTR] * * Assign values to the array elements... STORE VAL(counter) TO number&counter STORE 'EXAMPLE ' + coun