home *** CD-ROM | disk | FTP | other *** search
/ The CIA World Factbook 1992 / k3bimage.iso / sel / 12 / 0021 / screen.bas < prev    next >
Encoding:
BASIC Source File  |  1991-12-02  |  12.8 KB  |  280 lines
  1.       REM $INCLUDE: 'LISTING.BAS'
  2.       DEFINT A-Z
  3.       REM $INCLUDE: 'SUBDIM.BAS'
  4.       REM $INCLUDE: 'SHARED.BAS'
  5.  
  6. SUB CHKDAT (DAT$,ED) STATIC
  7.       IF NOT ED AND DAT$=SPACE$(6) THEN EN=102 : CALL DISERR (EN,ER$) : EXIT SUB
  8.       IF     ED AND DAT$=SPACE$(6) THEN EXIT SUB
  9.       IF (LEFT$(DAT$,2)>"00") AND (LEFT$(DAT$,2)<"13") AND (MID$(DAT$,3,2)>"00") AND (MID$(DAT$,3,2)<"32") AND (RIGHT$(DAT$,2)>"85") THEN EXIT SUB
  10.       EN=107:  CALL DISERR (EN,ER$)
  11. END SUB
  12. SUB CHKTIM (TIM$,ED) STATIC
  13.       IF NOT ED AND TIM$=SPACE$(4) THEN EN=102 : CALL DISERR (EN,ER$) : EXIT SUB
  14.       IF     ED AND TIM$=SPACE$(4) THEN EXIT SUB
  15.       IF (LEFT$(TIM$,2)<"24") AND (RIGHT$(TIM$,2)>"  ") AND (RIGHT$(TIM$,1)<>" ") AND (RIGHT$(TIM$,2)<"60") THEN EXIT SUB
  16.       EN=108 : CALL DISERR (EN,ER$)
  17. END SUB
  18.  
  19. SUB CHGATTR (ROW,SCOL,ECOL,ATTR) STATIC
  20.       DEF SEG=&H40
  21.       REM IF CRT = 1  THEN 40 X 25 COLOR
  22.       REM IF CRT = 32 THEN 80 X 25 COLOR
  23.       REM IF CRT = 48 THEN MONOCHROME
  24.       REM IF CRT = 64 THEN BOTH
  25.       CRT = PEEK(&H10)
  26.         IF (CRT=48) OR (CRT=113) THEN DEF SEG=&HB000 ELSE DEF SEG=&HB800
  27.         PT = ((ROW-1)*160) + ((SCOL-1)*2) + 1
  28.         FOR N = 1 TO (ECOL-SCOL+1)
  29.         POKE PT+((N-1)*2),ATTR
  30.         NEXT N
  31. END SUB
  32.  
  33. SUB FUNCTIONS (FLD$) STATIC
  34.       KEY OFF
  35.       FOR N = 1 TO 10
  36.       KEY N,""
  37.       NEXT N
  38.       AB=1 :COL=1 :N=1
  39.       LOCATE 25,1 : PRINT SPC(72);
  40. 50    WHILE AB<LEN(FLD$)
  41.       IF MID$(FLD$,AB,1)="," THEN AB=AB+1 : N=N+1 : GOTO 50
  42.       AE=((INSTR(AB,FLD$,","))-AB)
  43.       IF AE <= 0 THEN AE=LEN(FLD$)+1-AB
  44.       LOCATE 25,COL : COLOR SFG,SBG : PRINT "[F";LEFT$((MKI$(N+48)),1);"]"; : COLOR RFG,RBG : PRINT MID$(FLD$,AB,AE); : COLOR SFG,SBG
  45.       L=LEN(MID$(FLD$,AB,AE)) : AB=AB+L+1 : N=N+1 : COL=COL+L+6
  46.       WEND
  47.       COLOR FG,BG
  48. END SUB
  49. SUB ACCEPT (FLD$,F$) STATIC
  50.       CALL LODARG (FLD$,N)
  51.       IF LEFT$((ARG$(1)),1) = ";" THEN F$="" : KY=0 : EXIT SUB
  52.       YES = NOT NO : NO = NOT YES
  53.       IF INSTR(1,ARG$(3),"LCK")   THEN KY=0 : EXIT SUB
  54.       IF INSTR(1,ARG$(3),"ALP")   THEN AP=YES ELSE AP=NO
  55.       IF INSTR(1,ARG$(3),"CAP")   THEN CP=YES ELSE CP=NO
  56.       IF INSTR(1,ARG$(3),"NUM")   THEN NM=YES ELSE NM=NO
  57.       IF INSTR(1,ARG$(3),"NODEF") THEN DF=NO  ELSE DF=YES
  58.       IF INSTR(1,ARG$(3),"FIX")   THEN FX=YES ELSE FX=NO
  59.       IF INSTR(1,ARG$(3),"DEC")   THEN DC=YES ELSE DC=NO
  60.       IF INSTR(1,ARG$(3),"REV")   THEN RV=YES ELSE RV=NO
  61.       IF INSTR(1,ARG$(3),"DATE")  THEN DT=YES : NM=YES ELSE DT=NO
  62.       IF INSTR(1,ARG$(3),"TIME")  THEN TM=YES : NM=YES ELSE TM=NO
  63.       IF INSTR(1,ARG$(5),"YES") OR EDITMODE=YES THEN ED=YES ELSE ED=NO
  64.       IF DC THEN DEF$="   " ELSE DEF$=" "
  65.       IF NM AND NOT DC AND DF THEN DEF$="0"
  66.       IF NM AND     DC AND DF THEN DEF$="0.00"
  67.       FL=VAL(ARG$(4))
  68.       IF VAL(ARG$(1))<>0 THEN LOCATE VAL(ARG$(1)),VAL(ARG$(2)) ELSE LOCATE ,VAL(ARG$(2))
  69.       ON ERROR GOTO INPERR
  70.       GOSUB GETINP
  71.       ON ERROR GOTO 0
  72.       EXIT SUB
  73. GETINP:
  74.       REM F$ = FIELD/PROMPT TO BE DISPLAYED
  75.       REM FL = FIELD LENGTH
  76.       REM WL = CHARACTER COUNT
  77.       REM WI = COLUMN POINTER
  78.       REM QY = CURRENT LINE
  79.       REM QX = CURRENT COLUMN
  80.       REM DP = DECIMAL COUNT
  81.       REM ES = ERROR SWITCH
  82.       REM W$ = INPUT CHARACTER
  83.       REM KY = FUNCTION/CONTROL KEY ENTERED
  84. 100   DP=0: WL=0: WI=1: IN$=INKEY$ : TRANSFER=NO : BYTS!=FRE("")
  85.       QX= POS(0):  QY=CSRLIN
  86.       IF NOT DT OR TM     THEN IN$= SPACE$(FL)
  87.       IF DT  AND  F$=""   THEN IN$="  /  /  "  : FL=FL+2 : GOTO 490
  88.       IF DT  AND  F$<>""  THEN IN$=LEFT$(F$,2)+"/"+MID$(F$,3,2)+"/"+RIGHT$(F$,2) : FL=FL+2 : WL=LEN(IN$) : GOTO 490
  89.       IF TM  AND  F$=""   THEN IN$="  :  "  : FL=FL+1 : GOTO 490
  90.       IF TM  AND  F$<>""  THEN IN$=LEFT$(F$,2)+":"+RIGHT$(F$,2) : FL=FL+1 : WL=LEN(IN$) : GOTO 490
  91.       IF NOT DF           THEN 590
  92.       IF F$="" OR F$=SPACE$(FL+DC) THEN 490
  93.       IF NOT DC           THEN 470
  94.       IN$=LEFT$(F$,FL-3)+"."+RIGHT$(F$,2) : WL=LEN(IN$) : GOTO 490
  95. 470   IN$= LEFT$(F$+SPACE$(FL),FL):  WL=LEN(F$)
  96. 480   IF MID$(IN$,WL,1)=" " THEN WL=WL-1:  IF WL>0 THEN 480
  97. 490   IF RV THEN COLOR RFG,RBG ELSE COLOR FG,BG
  98.       LOCATE QY,QX,1: PRINT IN$;
  99. 510   LOCATE QY,QX+WI-1
  100. 520   IF (DT OR TM) AND ((MID$(IN$,WI,1)="/") OR (MID$(IN$,WI,1)=":"))  THEN WI=WI+1 : LOCATE QY,QX+WI-1
  101. 530   W$=INKEY$: DEF SEG=&H40: QK=PEEK(&H17) AND 96:
  102.       IF QK1<>QK THEN LOCATE 25,73: COLOR RFG,RBG : PRINT LOCKS$(QK/32);: QK1=QK: SOUND 400+QK,.3: GOTO 590
  103.       IF DATSW THEN CALL DISDATE
  104.       IF W$=""          THEN 530
  105.       KY=0
  106.       IF ES             THEN LOCATE 24,1 : COLOR FG,BG: PRINT SPC(40); : LOCATE QY,QX+WI-1 : ES=NO : IF RV THEN COLOR RFG,RBG
  107.       IF LEN(W$)=1      THEN 660  ELSE  KY= ASC(RIGHT$(W$,1))
  108.       IF KY>=F1 AND KY<=F10 THEN RETURN
  109.       IF KY= CTRL.RT    THEN 860
  110.       IF KY= CTRL.LF    THEN 860
  111.       IF KY= PG.UP      THEN 860
  112.       IF KY= PG.DN      THEN 860
  113.       IF KY= RT.CURSOR  AND (AP OR DT OR TM) THEN WI=WI-(WI<(WL+1)): GOTO 510
  114.       IF KY= LF.CURSOR  AND  AP              THEN WI=WI+(WI> 1): GOTO 510
  115.       IF KY= LF.CURSOR  AND (DT OR TM)       THEN IF (WI>1) THEN WI=(WI-1+(("/"=MID$(IN$,WI-1,1)) XOR (":"=MID$(IN$,WI-1,1)))) : GOTO 510
  116.       IF NOT AP         THEN 520
  117.  
  118.       IF KY= INS.KEY    THEN IF INSERT=NO THEN INSERT=YES: LOCATE,,,CU1,CU2: GOTO 490 ELSE INSERT=NO:  LOCATE,,,CU2: GOTO 520
  119. REM   IF KY= LF.CURSOR  THEN WI=WI+(WI> 1): GOTO 510
  120.       IF KY= DEL.KEY    THEN IF WL<>0 AND WI<=FL AND WL>=WI THEN IN$= LEFT$(IN$,WI-1)+RIGHT$(IN$,FL-WI)+" ": WL=WL-1: TRANSFER=YES : GOTO 490
  121.       IF INSERT         THEN INSERT=NO: LOCATE,,,CU2
  122.       IF KY= CTRL.HOME  THEN WI=1: GOTO 510
  123.       IF KY= CTRL.END   THEN WI= WL+1:  GOTO 510
  124.       IF KY= HOME       THEN IN$=LEFT$(IN$,WI-1)+SPACE$(FL-WI+1): WL=WI-1: TRANSFER=YES : GOTO 490
  125.                            GOTO 510
  126. 590   IF RV THEN COLOR RFG,RBG ELSE COLOR FG,BG
  127.                            GOTO 510
  128. 660   IF W$= NTR$       THEN 860
  129.       IF W$= ESC$       THEN KY=ESC : RETURN
  130.       IF WI>FL          THEN IF W$<> BKSP$ THEN ERROR 101 : GOTO 510
  131. 730   IF AP AND NOT CP  THEN IF W$>=" " AND W$<="~" THEN 750
  132.       IF NM             THEN IF W$>="0" AND W$<="9" THEN 750
  133.       IF NM             THEN IF WI=1 AND W$="-" THEN 750
  134.       IF DC             THEN IF W$="." AND DP=0 THEN DP=1 : GOTO 770
  135.       IF AP AND CP      THEN IF W$>="a" AND W$<="z" THEN W$=CHR$(ASC(W$)-32): GOTO 750  ELSE IF W$>=" " AND W$<"a" THEN 750
  136.       IF W$=BKSP$ AND NOT (DT OR TM)   THEN IF WI>1 THEN                                                         MID$(IN$,WI-1,1)=" "   :  WL=WL-1  : WI=WI-1   : DP=DP+(DP>0) : LOCATE ,QX+WI-1: PRINT " ";: TRANSFER=YES : GOTO 510
  137.       IF W$=BKSP$ AND     (DT OR TM)   THEN IF WI>1 THEN N=(("/"=MID$(IN$,WI-1,1)) XOR (":"=MID$(IN$,WI-1,1))) : MID$(IN$,WI-1+N,1)=" " : WL=WL-1+N : WI=WI-1+N : DP=DP+(DP>0) : LOCATE ,QX+WI-1: PRINT " ";: TRANSFER=YES : GOTO 510
  138.       IF NM             THEN IF W$<>BKSP$ THEN ERROR 103
  139.       GOTO 510
  140. 750   IF NOT DC         THEN 770 ELSE IF DP=0 AND W$<>"." AND WI=FL-2  THEN 520
  141.       IF DP=0           THEN 770 ELSE IF DP=3 THEN 520 ELSE DP=DP+1
  142. 770   IF NOT INSERT     THEN MID$(IN$,WI,1)=W$: TRANSFER=YES : GOTO 790
  143.       IF WL < FL        THEN WL=WL+1: IN$= LEFT$( LEFT$(IN$,WI-1) +W$ +RIGHT$(IN$,FL-WI+1), FL): WI=WI+1 : TRANSFER=YES : GOTO 490  ELSE 520
  144. 790   IF DT OR TM OR (WI>1)   THEN 820
  145.       IN$=W$+SPACE$(FL-1) : IF W$<>"." THEN DP=0
  146.       LOCATE,QX: PRINT IN$;: LOCATE,QX: WL=1
  147. 820   PRINT W$;
  148.       WI=WI+1: IF WI>WL THEN WL=WI-1
  149.       GOTO 520
  150. 860   COLOR FG,BG:  LOCATE QY,QX,,CU2: INSERT=NO
  151.       IF KY<>0          THEN 960
  152.       IF WL=0 AND NOT ED THEN ERROR 102 : GOTO 510
  153.       IF FX   AND WL<>0 AND WL<FL   THEN ERROR 104 : GOTO 510
  154.       IF (NOT TRANSFER) AND (NOT DT) AND (NOT TM) AND ((WL=0 AND EDITMODE) OR (WL<>0)) THEN RETURN
  155.       IF DC THEN 900
  156.       IF DT             THEN F$=LEFT$(IN$,2)+MID$(IN$,4,2)+RIGHT$(IN$,2) : CALL CHKDAT (F$,ED) : IF ES THEN 510 ELSE RETURN
  157.       IF TM             THEN F$=LEFT$(IN$,2)+RIGHT$(IN$,2) : CALL CHKTIM (F$,ED) : IF ES THEN 510 ELSE RETURN
  158.       IF NM THEN 930
  159.       F$=LEFT$(IN$+SPACE$(FL),FL): PRINT F$; : RETURN
  160. 900   WHILE LEFT$(IN$,1)="0"
  161.       IN$=RIGHT$(IN$,FL-1)+" " : WL=WL-1
  162.       WEND
  163.       IF WL>0           THEN IN$=LEFT$(IN$,WL)+MID$(".00",DP+1,3-DP) ELSE IN$=DEF$ : WL=4 : DP=3
  164.       IN$=SPACE$(FL-WL-(3-DP))+IN$: PRINT IN$;
  165.       F$=LEFT$(IN$,FL-3)+RIGHT$(IN$,2) : RETURN
  166. 930   WHILE LEFT$(IN$,1)="0"
  167.       IN$=RIGHT$(IN$,FL-1)+" " : WL=WL-1
  168.       WEND
  169.       IF WL>0           THEN F$=SPACE$(FL-WL)+LEFT$(IN$,WL) ELSE F$=SPACE$(FL-1)+DEF$
  170.       PRINT F$; : RETURN
  171. 960   IF WL<>0 AND F$="" THEN 510
  172.       IF KY<>CTRL.LF AND NOT ED THEN ERROR 102 : GOTO 510
  173.       IN$= SPACE$(FL)
  174.       IF F$=""            THEN PRINT IN$; : RETURN
  175.       IF NOT DC           THEN 970
  176.       IF F$<>SPACE$(FL-1) THEN IN$=LEFT$(F$,FL-3)+"."+RIGHT$(F$,2) : PRINT IN$; : RETURN
  177. 970   IN$= LEFT$(F$+SPACE$(FL),FL) : PRINT IN$; : RETURN
  178. END SUB
  179. INPERR:
  180.       CALL DISERR (ERR,ER$)
  181.       RESUME NEXT
  182. SUB DISERR (EN,ER$) STATIC
  183.       COLOR HL,BG: LOCATE 24,1 : PRINT SPC(40); : BEEP : ES=YES : LOCATE ,1
  184.       IF EN<100         THEN PRINT "BASIC ERROR ="EN "LINE ="ERL;
  185.       IF EN>200         THEN COLOR BL : PRINT ER$;
  186.       IF EN=101         THEN PRINT "<<FIELD OVERFLOW>>";
  187.       IF EN=102         THEN PRINT "<<CAN'T OMIT>>";
  188.       IF EN=103         THEN PRINT "<<NON-NUMERIC>>";
  189.       IF EN=104         THEN PRINT "<<FIXED LENGTH INPUT>>";
  190.       IF EN=105         THEN PRINT "<<INVALID NUMBER>>";
  191.       IF EN=106         THEN PRINT "<<ENTRY ***VOIDED*** >>";
  192.       IF EN=107         THEN PRINT "<<INVALID DATE>>";
  193.       IF EN=108         THEN PRINT "<<INVALID TIME>>";
  194.  
  195.       IF EN=111         THEN PRINT "[RECORD NOT FOUND]";
  196.       IF EN=112         THEN PRINT "[END OF FILE]";
  197.       IF EN=113         THEN PRINT "[PARTIAL MATCH FOUND]";
  198.       IF EN=115         THEN PRINT "[INSUFFICIENT KEY INPUT]";
  199.       COLOR FG,BG
  200. END SUB
  201. SUB ASKUM (QUEST$,ANS$) STATIC
  202.       COLOR HL,BG : LOCATE 24,1 : PRINT SPC(80); : BEEP
  203.       PRINT QUEST$;"? [Y,N] <DEFAULT=N>:";
  204.       ANS$=""
  205.       WHILE ANS$=""
  206.       ANS$=INKEY$
  207.       WEND
  208.       LOCATE 24,1 : PRINT SPC(80);
  209.       IF (ANS$<>"Y" AND ANS$<>"y") THEN ANS$="N"
  210.       COLOR FG,BG
  211. END SUB
  212. SUB DISDATE STATIC
  213.      STATIC TIM$
  214.      IF LEFT$(TIM$,5)=LEFT$(TIME$,5) OR NOT DATSW THEN EXIT SUB
  215.      CX=CSRLIN : CY=POS(0)
  216.      DAT$=DATE$:TIM$=TIME$:X=VAL(TIM$):IF X>11 THEN CH$=" pm":X=X\13+X MOD 13 ELSE CH$=" am":IF X=0 THEN X=12
  217.      MSG$="Date: "+MID$("JanFebMarAprMayJunJulAugSepOctNovDec",3*VAL(DAT$)-2,3)+STR$(VAL(MID$(DAT$,4)))+", "+RIGHT$(DAT$,4)+"     Time:"+STR$(X)+MID$(TIM$,3,3)+CH$
  218.      COLOR HL,BG : LOCATE 1,22 : PRINT MSG$; : LOCATE CX,CY : COLOR FG,BG
  219. END SUB
  220. SUB DISPBIN (FLD$,BDATA,BUMP) STATIC
  221.       DATA$=STR$(BDATA)
  222.       CALL DISPLAY (FLD$,DATA$,BUMP)
  223. END SUB
  224. SUB DISPLAY (FLD$,DATA$,BUMP) STATIC
  225.       CALL LODARG (FLD$,N)
  226.       IF LEFT$((ARG$(1)),1) = ";" THEN EXIT SUB
  227.       LOCATE VAL(ARG$(1))+BUMP,VAL(ARG$(2))
  228.       IF INSTR(1,ARG$(3),"BLINK") THEN COLOR BL,BG
  229.       IF INSTR(1,ARG$(3),"REV")   THEN COLOR RFG,RBG
  230.       IF INSTR(1,ARG$(3),"HIGH")  THEN COLOR HL,BG
  231.  
  232.       IF DATA$="" THEN PRINT ARG$(4) : COLOR FG,BG : EXIT SUB
  233.       YES = NOT NO : NO = NOT YES
  234.       IF INSTR(1,ARG$(3),"ALP") THEN AP=YES ELSE AP=NO
  235.       IF INSTR(1,ARG$(3),"BIN") THEN BN=YES ELSE BN=NO
  236.       IF INSTR(1,ARG$(3),"NUM") THEN NM=YES ELSE NM=NO
  237.       IF INSTR(1,ARG$(3),"DEC") THEN DC=YES ELSE DC=NO
  238.       IF INSTR(1,ARG$(3),"DATE")  THEN DT=YES ELSE DT=NO
  239.       IF INSTR(1,ARG$(3),"TIME")  THEN TM=YES ELSE TM=NO
  240.       FL=VAL(ARG$(4))
  241.       IF (AP OR NM AND NOT DC) THEN PRINT DATA$; : COLOR FG,BG : EXIT SUB
  242.       IF BN THEN PRINT RIGHT$(SPACE$(FL)+DATA$,FL);  : COLOR FG,BG : EXIT SUB
  243.       IF DC AND DATA$=SPACE$(FL-1) THEN PRINT DATA$; : COLOR FG,BG : EXIT SUB
  244.       IF DC THEN PRINT LEFT$(DATA$,FL-3)+"."+RIGHT$(DATA$,2); : COLOR FG,BG : EXIT SUB
  245.       IF DT AND DATA$<>SPACE$(6) THEN PRINT LEFT$(DATA$,2)+"/"+MID$(DATA$,3,2)+"/"+RIGHT$(DATA$,2); : COLOR FG,BG : EXIT SUB
  246.       IF TM AND DATA$<>SPACE$(4) THEN PRINT LEFT$(DATA$,2)+":"+RIGHT$(DATA$,2);
  247.       IF DT AND DATA$=SPACE$(6) THEN PRINT SPC(8);
  248.       IF TM AND DATA$=SPACE$(4) THEN PRINT SPC(5);
  249.  
  250.       COLOR FG,BG
  251. END SUB
  252. SUB LODARG (FLD$,N) STATIC
  253.       AB=1 : AE=1 : N=0
  254.       WHILE AE>0
  255.       AE=INSTR(AB,FLD$,",")
  256.       N=N+1
  257.       IF AE>0 THEN ARG$(N) = MID$(FLD$,AB,AE-AB) ELSE ARG$(N) = MID$(FLD$,AB)
  258.       AB=AE+1
  259.       WEND
  260. END SUB
  261. SUB LODWK1 (FLD$,N) STATIC
  262.       AB=1 : AE=1 : N=0
  263.       WHILE AE>0
  264.       AE=INSTR(AB,FLD$,",")
  265.       N=N+1
  266.       IF AE>0 THEN WRK1%(N) = VAL(MID$(FLD$,AB,AE-AB)) ELSE WRK1%(N) = VAL(MID$(FLD$,AB))
  267.       AB=AE+1
  268.       WEND
  269. END SUB
  270. SUB LODWK2 (FLD$,N) STATIC
  271.       AB=1 : AE=1 : N=0
  272.       WHILE AE>0
  273.       AE=INSTR(AB,FLD$,",")
  274.       N=N+1
  275.       IF AE>0 THEN WRK2%(N) = VAL(MID$(FLD$,AB,AE-AB)) ELSE WRK2%(N) = VAL(MID$(FLD$,AB))
  276.       AB=AE+1
  277.       WEND
  278. END SUB
  279.  
  280.