home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / rbsrc / rb-creat.scr < prev    next >
Text File  |  1988-04-24  |  31KB  |  1 lines
  1. \ RazorBack                                  hs  18:14 03/16/88                                                                                                                                                                                                                                                                          *****************************************                       *   F A R   S I D E   R E S E A R C H   *                       *           (C) 1987,1988               *                       *****************************************                                                                                                                                                                                                                                                                                                                                                                                                                                                                              \ Load Screen                                    11:48 02/26/88                                                                                                                                 : MARKER ;                                                      2 29 THRU                                                       2 29 THRU                                                       BSAVE OVERLAY RBMAINT                                           FORGET MARKER                                                   BYE                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                             ( variables -- window                          10:16 02/09/87 )                                                                 FORTH DEFINITIONS DECIMAL                                       BSTART OVERLAY                                                                                                                  VARIABLE 'HELP                                                  VARIABLE FILL-CHAR                                              VARIABLE ANCHOR                                                                                                                 0 0  23 79 WINDOW CURRENTW       \ current window               0 0  23 79 WINDOW VIRTUALW       \ the work window              5 5  6  45 WINDOW INFW                                                                                                                                                                                                                                                                                                          \ Includes & etc.                                10:17 01/20/88                                                                 INCLUDE FIELD.DEF                                               INCLUDE FILES.DEF                                               INCLUDE REPORT.DEF                                              INCLUDE VIEW.DEF                                                DICTIONARY WRK.DCT NULL                                         DICTIONARY WRK.DAT NULL                                         DICTIONARY WRK.RPT NULL                                         HCB WRK.LAY                                                                                                                                                                                     : FLD-ERASE  FLD.BUFF SIZEOF FIELD ERASE                                     513 FLD.BUFF FLD.MS/LS ! ;                                                                                                                                                         \ char maint                                     15:03 04/13/88                                                                 VARIABLE #CHARS #CHARS OFF                                                                                                      : CHAR++   1 #CHARS +! ;                                                                                                        : CHAR--   #CHARS @ 1- 0 MAX #CHARS ! ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                         \ add-db                                     hs  10:18 01/20/88                                                                 : ADD-DB   " File Information" EDITL SINGLE INFW OPEN-WINDOW               2 2 INFW NOR " Description:" WND-CSTR!                          2 3 INFW NOR " FileName  :" WND-CSTR!                           0 LC.BUFF LC.FLG C! LC.BUFF LC.DESCR 30 BLANK                  15 2 INFW LC.BUFF LC.DESCR 30 @STRING DROP                       LC.BUFF LC.FNAME 8 BLANK                                       15 3 INFW LC.BUFF LC.FNAME 8 @STRING DROP                        INFW CLOSE-WINDOW                                               LC.BUFF LCMAIN.DCT ADD-ITEM DUP ANCHOR !                        WRK.DCT OVER NAME>DCT                                           WRK.DAT SWAP NAME>DAT                                           SIZEOF FIELD WRK.DCT MAKE-DICTIONARY ;                                                                                                                                               \ relative coords                            hs  10:18 01/20/88                                                                 ( -- col row )                                                  : ?XY-WINDOW  ?XY CURRENTW WINDOW-ROW C@ - >R                                 CURRENTW WINDOW-COL C@ - R> ;                                                                                     ( col row -- addr len )                                         : RC->STR    100 * + S>D <# # # ASCII , HOLD # # #> ;                                                                                                                                           : TITS       PAD 80 BLANK                                                    0 24 FULLW REV 80 PAD WND-STR!                                  2 24 FULLW REV 30 LC.BUFF LC.DESCR WND-STR!                    45 24 FULLW REV " Design a Form"  WND-CSTR! ;                                                                                                                                       \ coord                                      hs  10:18 01/20/88                                                                 : COORD      70 24 FULLW REV ?XY RC->STR SWAP WND-STR! ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        \ clear                                      hs  10:18 01/20/88                                                                                                                                 : CLEAR      VIRTUALW BOX-CLR                                                1 1 GOTOXY                                                      32 FILL-CHAR !                                                  0 CURRENTW WINDOW-COL !                                         0 0              ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                 \ help                                       hs  10:18 01/20/88                                                                 : WND-HELP  0 " HELP" BRUN HELP FORGET OVERLAY 00 00 ;                                                                          ( char -- t/f )                                                 : ISASCII   126 32 ISSET ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      \ up & down                                  hs  10:18 01/20/88                                                                                                                                 : UP   #CHARS OFF                                                      ?XY-WINDOW NIP 1 = IF ERRTONE 00 00                                                      ELSE 00 -1 THEN   ;                                                                             : DOWN #CHARS OFF ?XY-WINDOW NIP                                       CURRENTW WINDOW-#ROW C@ 1- =                                    IF ERRTONE 00 00 ELSE 00 01 THEN ;                                                                                       ( -- cl-off rw-off )                                            : LF/CR  DOWN NIP                                                        ?XY-WINDOW DROP 1- NEGATE SWAP ;                                                                                                                                                       \ right & left                               hs  10:18 01/20/88                                                                                                                                 : RIGHT ?XY-WINDOW DROP 1 = IF ERRTONE 00 00                                                ELSE -1 00 THEN   ;                                                                                                                                                 : LEFT ?XY-WINDOW DROP                                                 CURRENTW WINDOW-#COL C@ 1- =                                    IF ERRTONE 00 00 ELSE 01 00 THEN ;                                                                                                                                                                                                                                                                                                                                                                                                                       \ bck_space & space                          hs  10:18 01/20/88                                                                 ( -- cl-off rw-off )                                            : BCK_SP ?XY-WINDOW SWAP DUP 0<> IF 1- THEN SWAP CURRENTW NOR 32         WND-CHAR! RIGHT                                                 CHAR-- 32 #CHARS @ FLD.BUFF FLD.NAME + C! ;                                                                            ( -- cl-off rw-off )                                            : SPACE  LEFT #CHARS @ IF CHAR++ THEN ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                         \ redo:                                      hs  10:18 01/20/88                                                                                                                                 : REDO:    20 0 ?DO                                                               FLD.BUFF FLD.NAME 19 I - + C@                                   126 33 ISSET                                                    IF ASCII : FLD.BUFF FLD.NAME 19 I 1- - + C!                        21 I - LEAVE                                                 THEN                                                          LOOP ;                                                                                                                                                                                                                                                                                                                                                                                                                                          \ .fields                                  h hs  10:18 01/20/88                                                                 \ When F2 is pushed show the current record information                                                                                                                                         : .FIELDS   WRK.DCT CLOSE-DICTIONARY                                        WRK.DCT " RBEFLDS" BRUN RBEFLDS FORGET OVERLAY                  CLS TITS OBOX 1 1 CURRENTW WND-GOTOXY                           WRK.DCT OPEN-DICTIONARY WRK.DCT D.HU @ 0                       ?DO                                                               FLD.BUFF I WRK.DCT DICT-READ                                    FLD.BUFF FLD.COL C@                                             FLD.BUFF FLD.ROW C@                                             FULLW HIL REDO: FLD.BUFF FLD.NAME WND-STR!                     LOOP 00 00 ;                                                                                                        \ add-field                                  hs  10:18 01/20/88                                                                 : ADD-FIELD    0 FLD.BUFF FLD.TYPE C!                                          5 FLD.BUFF FLD.LENGTH !                                         #CHARS C@ FLD.BUFF FLD.NLEN C!                                  FLD.BUFF WRK.DCT ADD-ITEM DROP #CHARS OFF                       FLD-ERASE ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      \ char-process                               hs  10:18 01/20/88                                                                 ( char -- cl-off rw-off flag )                                  : CHAR-PROCESS  DUP ISASCII                                                     IF                                                               DUP ASCII : = IF ADD-FIELD                                      ELSE                                                              #CHARS @ 0= IF FLD.BUFF FLD.NAME 20 BLANK                                      ?XY-WINDOW FLD.BUFF FLD.ROW C!                                  FLD.BUFF FLD.COL C! THEN                         #CHARS @ 20 < IF                                                DUP #CHARS @ FLD.BUFF FLD.NAME + C!                             CHAR++ THEN                                                   THEN                                                            >R ?XY-WINDOW CURRENTW HIL R> WND-CHAR! 0 LEFT                 ELSE DROP ERRTONE 0 0 0 THEN 0 ;                \ process                                  h hs  10:18 01/20/88                                                                 : PROCESS  PCKEY ?DUP 0= IF 100 + THEN                                     CASE                                                  168 OF -1 00 00    ENDOF ( f10   f1 ) 159 OF 0 WND-HELP  ENDOF   27 OF 0  00 00    ENDOF ( esc   f3 ) 161 OF 0 0 0       ENDOF  163 OF 0  00 00    ENDOF ( f5    f6 ) 164 OF 0 0 0       ENDOF  172 OF 0 UP        ENDOF ( up    dw ) 180 OF 0 DOWN      ENDOF  177 OF 0 LEFT      ENDOF ( lft   rg ) 175 OF 0 RIGHT     ENDOF   32 OF 0 SPACE     ENDOF ( sp    cr )  13 OF 0 LF/CR     ENDOF  160 OF 0 .FIELDS   ENDOF ( f2       )  08 OF 0 BCK_SP    ENDOF            CHAR-PROCESS                                                    ENDCASE                                                         ?XY ROT + >R + R> GOTOXY COORD ;                                                                                                                                                     \  Del-warn                                      10:33 04/14/88                                                                 7 10 8 50 WINDOW WARNW                                                                                                          : DEL-WARN   ( --- t/f ) ALARM                                               " DataBase Delete" NONE SINGLE WARNW OPEN-WINDOW                2 2 WARNW HIL " By deleting this database, all the information" WND-CSTR!                                                       2 3 WARNW HIL " contained in it will be destroyed. If it is "  WND-CSTR!                                                        2 4 WARNW HIL " referenced by another file, those refenences "  WND-CSTR!                                                       2 5 WARNW HIL " will be meaningless. " WND-CSTR!                4 7 WARNW NOR " Do you wish to CONTINUE?" WND-CSTR!            30 7 WARNW 0 ?YES/NO NIP                                         WARNW CLOSE-WINDOW ;                               \ <delete>                                       10:33 04/14/88                                                                                                                                 : <delete>   ( #file --- )                                                   WRK.DCT OVER NAME>DCT WRK.DCT FDEL DROP                         WRK.DCT OVER NAME>DAT WRK.DCT FDEL DROP                         WRK.DCT OVER NAME>RPT WRK.DCT FDEL DROP                         WRK.DCT OVER NAME>VIEW WRK.DCT FDEL DROP                        WRK.DCT HCB>N -EXT " .LAY" +EXT WRK.DCT NAME>HCB                WRK.DCT FDEL 2DROP                                              WRK.DCT HCB>N -EXT " .FLT" +EXT WRK.DCT NAME>HCB                WRK.DCT FDEL DROP                                               WRK.DCT HCB>N -EXT " .X??" +EXT WRK.DCT NAME>HCB                WRK.DCT WRK.DAT 0 FFIRSTF NOT IF                                BEGIN WRK.DAT FDEL DROP                                               WRK.DAT FNEXTF UNTIL THEN ;                  \ del-db                                         10:39 04/14/88                                                                                                                                 : DEL-DB    " Delete A Database" @ACTIVES ?DUP                              IF 1-                                                              DEL-WARN IF DUP LCMAIN.DCT DEL-ITEM                                         <delete>                                                     ELSE DROP THEN                                       THEN ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                             \ mod-warn                                       09:17 04/22/88                                                                 : MOD-WARN   ( --- t/f ) ALARM                                               " DataBase Modify" NONE SINGLE WARNW OPEN-WINDOW                2 2 WARNW HIL " By modifing this database, all the information" WND-CSTR!                                                       2 3 WARNW HIL " contained in it will be destroyed. If it is "  WND-CSTR!                                                        2 4 WARNW HIL " referenced by another file, those refenences "  WND-CSTR!                                                       2 5 WARNW HIL " will be meaningless. " WND-CSTR!                4 7 WARNW NOR " Do you wish to CONTINUE?" WND-CSTR!            30 7 WARNW 0 ?YES/NO NIP                                         WARNW CLOSE-WINDOW ;                                                                                                                                                               \ edit-db                                    hs  10:18 01/20/88                                                                 : EDIT-DB  " Active DataBases" @ACTIVES ?DUP                               IF 1- MOD-WARN IF                                                     DUP ANCHOR ! WRK.DCT OVER NAME>DCT                           WRK.DAT SWAP NAME>DAT                                        WRK.DCT OPEN-DICTIONARY                                         WRK.DCT D.HU @ 0                                                ?DO                                                               FLD.BUFF I WRK.DCT DICT-READ                                    FLD.BUFF FLD.COL C@                                             FLD.BUFF FLD.ROW C@                                             FULLW HIL REDO: FLD.BUFF FLD.NAME WND-STR!                    LOOP                                                            WRK.DCT CLOSE-DICTIONARY -1 ELSE DROP 0 THEN                    ELSE 0 THEN ;                                        \ mode choice                                hs  10:18 01/20/88                                                                 : MODES  " Create    Modify    Delete    " ;                                                                                    MODES  3 10 10 CHOICE MODEC               \ operation mode      3  2  4 14 WINDOW MODEW                   \ mode window                                                                         : @MODE  " DataBases" NONE SINGLE MODEW OPEN-WINDOW                      MODEW MODEC CHOOSE                                              MODEW CLOSE-WINDOW CLS OBOX                                     CASE                                                               0 OF           0 ENDOF                                          1 OF ADD-DB   -1 ENDOF                                          2 OF EDIT-DB     ENDOF                                          3 OF DEL-DB    0 ENDOF                                       ENDCASE ;                                              \ make-idx                                       13:15 04/18/88                                                                 HCB T.IDX                                                                                                                       CREATE T.BUFF   300 ALLOT  T.BUFF 300 255 FILL                                                                                  : MAKE-IDX   ( num --- )                                                     FLD.BUFF FLD.?IDX C@                                            IF WRK.DCT HCB>N T.IDX NAME>HCB                                    T.IDX SWAP CHG-IDX                                              T.IDX 0 FMAKE DROP                                              T.IDX T.BUFF 300 FWRITE DROP                                    T.IDX FCLOSE DROP                                             ELSE DROP THEN ;                                                                                                                                                                  \ make-dat                                   hs  10:19 01/20/88                                                                 CREATE  LENGTH-TAB 0 C, 4 C, 4 C, 2 C, 4 C, 10 C, 1 C, 0 C, 2 C,                                                                DICTIONARY TMP.DCT TEMP                                                                                                         : MAKE-DAT  TMP.DCT OPEN-DICTIONARY 1 WRK.DCT D.HU @ 0                      ?DO FLD.BUFF I WRK.DCT DICT-READ DUP                              FLD.BUFF FLD.OFFSET ! FLD.BUFF ?ACTIVE IF                       FLD.BUFF TMP.DCT ADD-ITEM MAKE-IDX THEN                         FLD.BUFF FLD.TYPE C@ DUP LENGTH-TAB + C@ SWAP DUP               0= SWAP 7 = OR IF FLD.BUFF FLD.LENGTH @ + THEN +              LOOP                                                            WRK.DAT MAKE-DICTIONARY TMP.DCT CLOSE-DICTIONARY                WRK.DCT CLOSE-DICTIONARY  WRK.DCT FDEL DROP                     TMP.DCT WRK.DCT FREN DROP TMP.DCT FDEL DROP ;       \ make-flt                                       13:01 04/15/88                                                                                                                                 : MAKE-FLT    T.BUFF 50 ERASE                                                 WRK.RPT HCB>N -EXT " .FLT" +EXT WRK.RPT NAME>HCB                WRK.RPT 0 FMAKE DROP                                            15 0 ?DO                                                        WRK.RPT T.BUFF 50 FWRITE DROP                                   LOOP                                                            WRK.RPT FCLOSE DROP ;                                                                                                                                                                                                                                                                                                                                                                                                                             \ make-afiles                                    15:02 04/13/88                                                                 : MAKE-AFILES ( --- )                                                     SIZEOF FIELD TMP.DCT MAKE-DICTIONARY                            WRK.RPT ANCHOR @ NAME>RPT                                       WRK.DCT HCB>N -EXT " .LAY" +EXT WRK.LAY NAME>HCB                WRK.LAY 0 FMAKE DROP WRK.LAY FCLOSE DROP                        SIZEOF REPORT WRK.RPT MAKE-DICTIONARY                           WRK.RPT ANCHOR @ NAME>VIEW                                      SIZEOF VIEW WRK.RPT MAKE-DICTIONARY                             MAKE-FLT                                                        MAKE-DAT ;                                                                                                                                                                                                                                                                                                            \ rbmaint                                    hs  10:19 01/20/88                                                                 : RBMAINT   @MODE IF                                                        TITS                                                            1 1 CURRENTW WND-GOTOXY                                         FLD-ERASE                                                       WRK.DCT OPEN-DICTIONARY                                         BEGIN PROCESS UNTIL                                             MAKE-AFILES                                                     0 0 GOTOXY THEN ;