!
! DEMO72.bas - AM72 & MOUSE Demo Program
!               Works with 480 line or 350 line monitors
!

PROGRAM DEMO72,1.0

++INCLUDE       AMGSYM.BSI
++INCLUDE       FILES.MAP

MAP1    GCB                     , X,56000
MAP1    DSP'MAX                 , F,  6, 100
MAP1    DSP'ARRAY
       MAP2    DSP'COUNT       , B,  2
       MAP2    DSP'XY(100)
               MAP3    DSP'X   , B,  2
               MAP3    DSP'Y   , B,  2

MAP1    POINT'MAX               , F,  6, 100
MAP1    POINT'ARRAY
       MAP2    POINT'COUNT     , B,  2
       MAP2    POINTS(100)
               MAP3    POINT'X , B,  2
               MAP3    POINT'Y , B,  2

MAP1    MAX'ZONES               , F,  6, 20
MAP1    ZONES(20)
       MAP2    ZONES'X(2)      , F,  6
       MAP2    ZONES'Y(2)      , F,  6

MAP1    TEXT'X(20)              , F,  6
MAP1    TEXT'Y(20)              , F,  6

MAP1    STATUS                  , F,  6 !Status retruned from AMIGOS calls
MAP1    TEXT$                   , S, 80
MAP1    FIL'STAT                , S,  3 ! FILE STATUS
MAP1    LEVEL                   , F,  6
MAP1    INDEX                   , F,  6
MAP1    ICONS                   , F,  6
MAP1    COMMAND                 , S,100 ! CHAINING COMMAND
MAP1    CRLF                    , S,  2 ! CARRIAGE RETURN & LINE FEED FOR COMMAND
MAP1    DO'FILE                 , S, 16 ! COMMAND FILE USED IN MEM0:
MAP1    IPF'FILE                , S, 16 ! CONFIG. FILE FOR LEVEL POSITIONING
MAP1    FILES(20)
       MAP2     F'LEVEL       , X,   2 !  Level:
       MAP2     F'DESC        , X,  30 !  Description:
       MAP2     F'TYPE        , S,   1 !  Type:
       MAP2     F'CMND'2      , S,  30 !  Command Line 2
       MAP2     F'CMND'1      , S,  30 !  Command Line 1
       MAP2     F'CMND'3      , S,  30 !  Command Line 3
       MAP2     F'CMND'4      , S,  30 !  Command Line 4
       MAP2     F'CMND'5      , S,  30 !  Command Line 5
       MAP2     F'CMND'6      , S,  30 !  Command Line 6
       MAP2     F'NEW'LEVEL   , B,   1 !  New Level

! FOR XCALL "TRMCHR"
MAP1    TRMCHR'MAP
       MAP2    TRMCHR'FLAGS    , F,  6
       MAP2    TRMCHR'ROWS     , F,  6
       MAP2    TRMCHR'COLS     , F,  6
       MAP2    TRMCHR'COLORS   , F,  6
       MAP2    TRMCHR'FORE     , F,  6
       MAP2    TRMCHR'BACK     , F,  6
       MAP2    TRMCHR'WINROW   , F,  6
       MAP2    TRMCHR'WINCOL   , F,  6


!***********************************************!
DEMO72:
!       ON ERROR GOTO ERROR'ROUTINE
       SIGNIFICANCE    11
       XCALL   TRMCHR, STATUS,TRMCHR'MAP
       PRINT   TAB(-2,1);      TAB(-3,0);

       LEVEL   = 1

       DO'FILE = "MEM0:DEMO72.DO"

       PRINT   TAB(-1,0);
       CRLF    = CHR(13) + CHR(10)
       GOSUB   DO'OVERHEAD             ! SET DEFAULTS
RQLC2:
       GOSUB   DO'EXIT'BOX             ! WRITE EXIT BOX
       GOSUB   CREATE'ZONES            ! CREATE THE ZONES FOR ICONS
       GOSUB   FILL'ZONES              ! FILL ZONES BASED ON FILES.IDA
       GOSUB   DO'SELECTION            ! GET THE SELECTION

END'IT:
       GOSUB   CLOSE'FILES
       XCALL   AMGSBR,G'CLWK,GCB,STATUS
       PRINT   TAB(-1,0);
       END
!***********************************************!
DO'OVERHEAD:
! Set Mouse Cursor Shape
       PRINT   TAB(-1,29);
       PRINT   TAB(-1,160);CHR(32+3);
! Open the workstation
       XCALL AMGSBR,G'OPWK,GCB,"",STATUS
! Clear the workstation
       XCALL AMGSBR,G'CLRW,GCB,STATUS
! Text Overhead
       XCALL   AMGSBR,G'STXF,GCB,1001,STATUS   ! font
       XCALL   AMGSBR,G'STXC,GCB,7,STATUS      ! color
       XCALL   AMGSBR,G'SCHH,GCB,1500,STATUS   ! height
       XCALL   AMGSBR,G'SCHR,GCB,300,STATUS    ! rotation
! Fill Area Overhead
       XCALL   AMGSBR,G'SFAC,GCB,4,STATUS      ! color
       XCALL   AMGSBR,G'SFAS,GCB,2,STATUS      ! style
       XCALL   AMGSBR,G'SFAI,GCB,55,STATUS     ! index

       RETURN
                                               !
!***********************************************!
DO'EXIT'BOX:
       ! Exit Box
       COLOR   = 7
       XMIN    =300
       XMAX    =3500
       YMIN    =23000
       YMAX    =24500

       EXIT'X1 =300
       EXIT'Y1 =23000
       EXIT'X2 =3500
       EXIT'Y2 =24500

       GOSUB   DISP'BOX                        ! exit box

       XCALL   AMGSBR,G'STXF,GCB,1001,STATUS   ! font
       XCALL   AMGSBR,G'STXC,GCB,2,STATUS      ! color
       XCALL   AMGSBR,G'SCHH,GCB,900,STATUS    ! height
       XCALL   AMGSBR,G'SCHR,GCB,0,STATUS      ! rotation
       TEXT$   ="EXIT"
       XVAL    =900
       YVAL    =23500
       GOSUB   DISP'TEXT

       XCALL   AMGSBR,G'STXF,GCB,1003,STATUS   ! font
       XCALL   AMGSBR,G'STXC,GCB,4,STATUS      ! color
       XCALL   AMGSBR,G'SCHH,GCB,1200,STATUS   ! height
       XCALL   AMGSBR,G'SCHR,GCB,0,STATUS      ! rotation
       TEXT$   = "AM72 DEMO SOFTWARE"
       XVAL    = 8100
       YVAL    = 23000
       GOSUB   DISP'TEXT

       XCALL   AMGSBR,G'STXF,GCB,1006,STATUS   ! font
       XCALL   AMGSBR,G'STXC,GCB,4,STATUS      ! color
       XCALL   AMGSBR,G'SCHH,GCB,1100,STATUS   ! height
       XCALL   AMGSBR,G'SCHR,GCB,0,STATUS      ! rotation
       TEXT$   = "- with mouse interface - "
       XVAL    = 7500
       YVAL    = 22000
       GOSUB   DISP'TEXT

       RETURN
!***********************************************!
CREATE'ZONES:
       ! Screen Frame
       COLOR   = 7
       POINT'X(1)      = 300
       POINT'Y(1)      = 300
       POINT'X(2)      = 300
       POINT'Y(2)      = 31000
       POINT'X(3)      = 31000
       POINT'Y(3)      = 31000
       POINT'X(4)      = 31000
       POINT'Y(4)      = 300
       POINT'X(5)      = POINT'X(1)
       POINT'Y(5)      = POINT'Y(1)

       XCALL   AMGSBR,G'SPLC,GCB,1,STATUS
       POINT'COUNT     =5
       XCALL   AMGSBR,G'PL,GCB,POINT'ARRAY,STATUS

       IF      (TRMCHR'ROWS = 24)      &
               YVAL    = 19200         &
       ELSE                            &
               YVAL    = 19800
       ZONES'KTR= 0

       FOR I   = 1 TO 10

       XVAL    = 500
               FOR X   = 1 TO 2
                       ZONES'KTR=ZONES'KTR+1

                       ZONES'X(ZONES'KTR,1)=XVAL
                       ZONES'Y(ZONES'KTR,1)=YVAL

                       ZONES'X(ZONES'KTR,2)=XVAL+1500
                       ZONES'Y(ZONES'KTR,2)=YVAL+1500

                       TEXT'X(ZONES'KTR)   =XVAL+2000
                       TEXT'Y(ZONES'KTR)   =YVAL+460

                       XVAL    = XVAL + 16000
               NEXT X
               IF      (TRMCHR'ROWS = 24)      &
                       YVAL    = YVAL - 1825   &
               ELSE                            &
                       YVAL    = YVAL - 2000

       NEXT I

       RETURN

!***********************************************!
FILL'ZONES:
       GOSUB   CLEAR'FILES'ARRAY
       GOSUB   OPEN'FILES
       FILES'KEY1 = SPACE(32)
       ICONS   = 0
       IF      (TRMCHR'ROWS = 24)      &
               ROW     = 5             &
       ELSE                            &
               ROW     = 6
       GOSUB   LOAD'ZONES'ARRAY

       FOR I   = 1 TO ICONS

       XCALL   AMGSBR,G'SWKV,GCB,ZONES'X(I,1),ZONES'Y(I,1),ZONES'X(I,2),ZONES'Y(I,2),STATUS

       GOSUB   DO'BOX

       XCALL   AMGSBR,G'SWKV,GCB,1,1,32000,32000,STATUS
       XCALL   AMGSBR,G'STXF,GCB,1001,STATUS   ! font
       XCALL   AMGSBR,G'STXC,GCB,7,STATUS      ! color
       XCALL   AMGSBR,G'SCHH,GCB,600,STATUS    ! height
       XCALL   AMGSBR,G'SCHR,GCB,0,STATUS      ! rotation

       XVAL    =TEXT'X(I)
       YVAL    =TEXT'Y(I)
!       TEXT$   = F'DESC(I)
!       GOSUB   DO'TEXT

! 480 line
       IF      (TRMCHR'ROWS <> 24)                     &
               IF      (INT(I/2) <> I/2)               &
                       PRINT   TAB(ROW,05);F'DESC(I);  &
               ELSE                                    &
                       PRINT   TAB(ROW,45);F'DESC(I);  : &
                       ROW     = ROW + 3

! 350 line
       IF      (TRMCHR'ROWS = 24)                      &
               IF      (INT(I/2) <> I/2)               &
                       PRINT   TAB(ROW,05);F'DESC(I);  &
               ELSE                                    &
                       PRINT   TAB(ROW,45);F'DESC(I);  : &
                       ROW     = ROW + 2

       NEXT I

       RETURN

!***********************************************!
DO'SELECTION:
       GOSUB   GETCOR                          ! mouse input
       GOSUB   CHECK'EXIT
       IF EXIT'FLAG=1          &
               ZONES'PNTR = 0  : &
               RETURN
       GOSUB   CHECK'ZONES
       IF      (ZONES'FLAG = 1)        &
               GOSUB   CHAIN'SELECTION : &
               RETURN

       GOTO    DO'SELECTION

CHECK'EXIT:
       EXIT'FLAG=0

       IF XVAL<(EXIT'X1-25) THEN RETURN
       IF XVAL>(EXIT'X2+25) THEN RETURN
       IF YVAL<(EXIT'Y1-25) THEN RETURN
       IF YVAL>(EXIT'Y2+25) THEN RETURN

       EXIT'FLAG=1

       RETURN

CHECK'ZONES:
       ZONES'FLAG=0

       FOR     SELECT = 1 TO ICONS
               IF XVAL<(ZONES'X(SELECT,1)-25) GOTO CHECK'ZONES'10
               IF XVAL>(ZONES'X(SELECT,2)+25) GOTO CHECK'ZONES'10
               IF YVAL<(ZONES'Y(SELECT,1)-25) GOTO CHECK'ZONES'10
               IF YVAL>(ZONES'Y(SELECT,2)+25) GOTO CHECK'ZONES'10
               ZONES'FLAG      = 1
               ZONES'PNTR      = SELECT
               SELECT          = ICONS

CHECK'ZONES'10:
       NEXT    SELECT

       RETURN

! *****************************************************
DO'BOX:
       COLOR   = VAL(F'TYPE(I))
       XMIN    =1500
       XMAX    =20000
       YMIN    =1500
       YMAX    =22000
       GOSUB   DISP'BOX

       RETURN
! *******************************************************

DISP'BOX:
       POINT'X(1)      =XMIN
       POINT'Y(1)      =YMIN
       POINT'X(2)      =XMIN
       POINT'Y(2)      =YMAX
       POINT'X(3)      =XMAX
       POINT'Y(3)      =YMAX
       POINT'X(4)      =XMAX
       POINT'Y(4)      =YMIN
       POINT'X(5)      =POINT'X(1)
       POINT'Y(5)      =POINT'Y(1)

       XCALL   AMGSBR,G'SPLC,GCB,1,STATUS
       XCALL   AMGSBR,G'SFAC,GCB,COLOR,STATUS  ! color
       POINT'COUNT     = 4
       XCALL   AMGSBR,G'FA,GCB,POINT'ARRAY,STATUS
       POINT'COUNT     = 5
       XCALL   AMGSBR,G'PL,GCB,POINT'ARRAY,STATUS
       RETURN

DISP'LINE:
       POINT'X(1)      =XMIN
       POINT'Y(1)      =YMIN
       POINT'X(2)      =XMIN
       POINT'Y(2)      =YMAX
       POINT'X(3)      =XMAX
       POINT'Y(3)      =YMAX
       POINT'X(4)      =XMAX
       POINT'Y(4)      =YMIN
       POINT'X(5)      =POINT'X(1)
       POINT'Y(5)      =POINT'Y(1)
DISP'LINE'10:
       POINT'COUNT     =5
       XCALL   AMGSBR,G'SPLC,GCB,COLOR,STATUS
       XCALL   AMGSBR,G'PL,GCB,POINT'ARRAY,STATUS
       RETURN

!***********************************************!
DO'TEXT:
       XCALL   AMGSBR,G'TX,GCB,XVAL,YVAL,TEXT$,STATUS
       RETURN
DISP'TEXT:
       XCALL   AMGSBR,G'TX,GCB,XVAL,YVAL,TEXT$,STATUS
       RETURN
!***********************************************!

GETCOR:
       XCALL AMGSBR,G'RQLC,GCB,0,0,0,XVAL,YVAL,CHAR,VALID
       RETURN

GETCOR1:
       XCALL AMGSBR,G'RQLC,GCB,XVAL,YVAL,2,XVAL,YVAL,CHAR,VALID
       RETURN
       END


CLEAR'FILES'ARRAY:
       FOR     ZIP = 1 TO 20
               F'LEVEL       = SPACE(2)
               F'DESC        = SPACE(30)
               F'TYPE        = SPACE(1)
               F'CMND'2      = SPACE(30)
               F'CMND'1      = SPACE(30)
               F'CMND'3      = SPACE(30)
               F'CMND'4      = SPACE(30)
               F'CMND'5      = SPACE(30)
               F'CMND'6      = SPACE(30)
               F'NEW'LEVEL   = 0
       NEXT    ZIP

       RETURN

LOAD'ZONES'ARRAY:
       GOSUB   FILES'GET'NEXT
       IF      (FIL'STAT <> "   ")             &
          OR   (VAL(FILES'LEVEL) <> LEVEL)     &
               RETURN


       ICONS           = ICONS + 1
       FILES(ICONS)    = FILES'RECORD

       GOTO    LOAD'ZONES'ARRAY

CHAIN'SELECTION:
       LOOKUP  DO'FILE,Q
       IF      (Q = 0)         &
               GOTO    CONT'CHAIN
       KILL    DO'FILE
       GOTO    CHAIN'SELECTION

CONT'CHAIN:
       COMMAND = SPACE(100)
       OPEN    #555,DO'FILE,OUTPUT
       PRINT   #555,":R"
       XCALL   STRIP, F'CMND'1(ZONES'PNTR)
       IF      (LEN(F'CMND'1(ZONES'PNTR)) > 0)         &
               PRINT   #555,F'CMND'1(ZONES'PNTR)

       XCALL   STRIP, F'CMND'2(ZONES'PNTR)
       IF      (LEN(F'CMND'2(ZONES'PNTR)) > 0)         &
               PRINT   #555,F'CMND'2(ZONES'PNTR)

       XCALL   STRIP, F'CMND'3(ZONES'PNTR)
       IF      (LEN(F'CMND'3(ZONES'PNTR)) > 0)         &
               PRINT   #555,F'CMND'3(ZONES'PNTR)

       XCALL   STRIP, F'CMND'4(ZONES'PNTR)
       IF      (LEN(F'CMND'4(ZONES'PNTR)) > 0)         &
               PRINT   #555,F'CMND'4(ZONES'PNTR)

       XCALL   STRIP, F'CMND'5(ZONES'PNTR)
       IF      (LEN(F'CMND'5(ZONES'PNTR)) > 0)         &
               PRINT   #555,F'CMND'5(ZONES'PNTR)

       XCALL   STRIP, F'CMND'6(ZONES'PNTR)
       IF      (LEN(F'CMND'6(ZONES'PNTR)) > 0)         &
               PRINT   #555,F'CMND'6(ZONES'PNTR)


       PRINT   #555,"RUN DEMO72"
       CLOSE   #555
       CHAIN   DO'FILE


! **************************************************
! ISAM FILE ACCESSING
! **************************************************
OPEN'FILES:
       FIL'STAT        = SPACE(3)
       OPEN    #FILES'CHN, FILES'FL$, INDEXED, FILES'RSZ, RECNO
       IF      (ERF(FILES'CHN) > 0)            &
               GOTO    REPORT'ERRORS

       RETURN

FILES'GET:
       FIL'STAT        = SPACE(3)
       ISAM    #FILES'CHN, 1, FILES'KEY1

       IF      (ERF(FILES'CHN) = 33)   &
               FIL'STAT        = "NOF" : &
               RETURN

       IF      (ERF(FILES'CHN) > 0)    &
               GOTO    REPORT'ERRORS

       GOSUB   READ'FILES
       RETURN

FILES'GET'NEXT:
       FIL'STAT        = SPACE(3)

       ISAM    #FILES'CHN, 2, FILES'KEY1
       IF      (ERF(FILES'CHN) = 38)   &
               FIL'STAT        = "EOF" : &
               RETURN

       IF      (ERF(FILES'CHN) = 33)   &
               FIL'STAT        = "NOF" : &
               RETURN

       IF      (ERF(FILES'CHN) > 0)    &
               GOTO    REPORT'ERRORS

       GOSUB   READ'FILES
       RETURN

READ'FILES:
       READ    #FILES'CHN, FILES'RECORD
       RETURN

CLOSE'FILES:
       CLOSE   #FILES'CHN
       RETURN


REPORT'ERRORS:
       PRINT   TAB(24,1);"ERROR # ";ERF(FILES'CHN);" -- ABORTING JOB"
       GOTO    END'IT

!++INCLUDE      BAS:ERROR.BSI

You are viewing proxied material from gopher.floodgap.com. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.