'===========================================================================
' Subject: COLOR-CODED BASIC SOURCE VIEWER   Date: 08-05-98 (08:32)       
' Author:  Ian Smith                         Code: PB                     
' Origin:  ian@isis.demon.co.uk            Packet: MISC.ABC
'===========================================================================
'BASVIEW v1.0
'============
'
'Written in and for for PowerBASIC 3.2.
'
'BASVIEW is a colour-coded BASIC source code viewer which is supposed to make
'the structure easier to understand. The current DATA terms are for PowerBASIC,
'but changing them should be quite easy. Basically, all it does is colour the
'PB keywords, comments and quotes. The control structures have their own colour.
'
'Current limits: 5000 lines of source
'                368 keyword/highlight colour defs
'
'It was written as a teaching aid and it's very much of the "quick and dirty"
'school with no attempt at any optimization, but it may be of interest.
'
'Fingers up nose - TAB handling is a bit dodgy
'                  incomplete keyword set
'                  simplistic keyword parsing
'                  shifting right mucks up the parsing
'                  the search is case sensitive
'                  it's slow
'
'Uses some free source picked up from several places, not least the ABC
'collection.
'Getinput came from usenet, but the author is unknown to me.
'The window stuff came originally from the ABC collection and the author
'is Alexander Podkolzin (app@sbank.e-burg.su).
'I've made some modifications so any screwups are my fault.
'
'My part in this is Public Domain.       Ian Smith - ian@isis.demon.co.uk
'========================================================================
'= Compiler instructions                                                =
'========================================================================

  $CPU 8086                             'compile for 8086
  $FLOAT EMULATE                        'small and universal arithmetic
  $OPTIMIZE SPEED                       'make a fast code
  $COMPILE EXE                          'make an EXE-File
  $DEBUG MAP OFF                        'no MAP-File
  $DEBUG PBDEBUG OFF                    'no code for the debugger
  $LIB COM OFF                          'don't support COMs
  $LIB CGA OFF                          'no CGA graphics
  $LIB EGA OFF                          'no EGA graphics
  $LIB VGA OFF                          'no VGA graphics
  $LIB HERC OFF                         'no Hercules graphics
  $LIB LPT OFF                          'don't support the printer
  $LIB IPRINT OFF                       'no interpreted print
  $ERROR BOUNDS OFF                     'don't check the array bondary
  $ERROR NUMERIC OFF                    'no numeric check
  $ERROR OVERFLOW OFF                   'no overflow check
  $ERROR STACK OFF                      'don't check the stack
  $COM 0                                'communication buffer = 0
  $SOUND 1                              'smallest possible sound buffer
  $STRING 32                            '32 KByte string memory
  $OPTION CNTLBREAK OFF                 'no ctrl+break
'========================================================================
  DECLARE SUB viewsrc (filename$)
  DECLARE SUB display (aline$, shft%)
  DECLARE SUB config()
  DECLARE SUB help()
  DECLARE SUB Getinput (Srow%, Scol%, Ilen%, Ip$, Retcode%, Posn%)
  DECLARE SUB Win(t%,Title$,yb%,xb%,ye%,xe%,ct%,cb%)
  DECLARE SUB SaveScreen(w$,yb%,xb%,ye%,yx%,sh%)
  DECLARE SUB RestoreScreen(w$,yb%,xb%)
  DECLARE SUB PutAttribute(x%,y%,t%,b%)

  DEFINT A-Z
  SHARED numk%, keyword$(), colour%(), Version$
  Version$ = "1.0"
  numk% = 368                           ' If the number of DATA statements is changed, so must this
  IF DIR$(Command$) = "" THEN
     PRINT "File " + Command$ + " not found"
     END
  END IF

  config                                'read in the keyword/colour deffs
  viewsrc Command$                      'view the file in all it's glory...

  COLOR 7,0
  CLS
  END
'------------------------------------------------------------------------
  SUB viewsrc (filename$)
'       view yer actual source file in luverly colour, ducks.

     DIM lines$(5000)
     STATIC pattern$
     shft% = 1
     linecnt% = 1
     OPEN filename$ FOR INPUT AS #1     ' get the source into memory
     DO WHILE NOT EOF (1)
        LINE INPUT #1, lines$(linecnt%)
        INCR linecnt%
     LOOP
     CLOSE
     COLOR 7,1
     CLS
'  Here we go, aloopin til we drop
     DO
        IF x% > linecnt% - 24 THEN x% = linecnt% - 24
        IF y% < 25 THEN y% = 25
        IF y% > linecnt% THEN y% = linecnt%
        IF x% < 1 THEN x% = 1
        LOCATE 1, 1
        COLOR 15, 3
        PRINT " Line :"; x%; "    ": LOCATE 1, 13: PRINT SPC(45);:PRINT "F1 = Help º Version ";:PRINT Version$;
        COLOR 7, 1
        xpos% = 2
        WHILE x% < y%
           LOCATE xpos%, 1
           display lines$(x%), shft%
           INCR x%
           INCR xpos%
        WEND
        x% = x% - 24
' F-key searches and the navigation stuff.
        DO
           WHILE INKEY$ <> "": WEND     ' empty buffer
           DO
              pressed$ = INKEY$
           LOOP UNTIL pressed$ <> ""
           SELECT CASE pressed$
              CASE CHR$(0, 61)          ' F3 - search again
                 n% = x% + 1
                 DO WHILE n% < linecnt%
                    IF TALLY (lines$(n%),pattern$) > 0 then
                       x% = n%
                       y% = x% + 24
                       tgt% = n%
                       EXIT DO
                    END IF
                    INCR n%
                 LOOP
                 IF n% = linecnt% THEN LOCATE 1,30:COLOR 0,3:PRINT "string not found !"
                 IF n% < linecnt% THEN EXIT DO

              CASE CHR$(0, 60)          ' F2 - search for word
                 savescreen helpscreen$,7,19,9,57,1
                 win 1,"Search",7,19,9,57,0,3
                 LOCATE 8,21: COLOR 15,3:PRINT "Search String:";
                 pattern$ = ""
                 COLOR 1,3: Getinput 8,36, 20, pattern$,0,0
                 restorescreen helpscreen$,7,19
                 LOCATE ,,0             ' hide the cursor
                 IF pattern$ <> "" THEN
                    n% = x%
                    DO WHILE n% < linecnt%
                       IF TALLY (lines$(n%),pattern$) > 0 THEN
                          x% = n%
                          y% = x% + 24
                          tgt% = n%
                          EXIT DO
                       END IF
                       INCR n%
                    LOOP
                    IF n% = linecnt% THEN LOCATE 1,30:COLOR 0,3:PRINT "string not found !"
                    IF n% < linecnt% THEN EXIT DO
                 END IF
              CASE CHR$(0, 59)          ' F1 - help
                 help
              CASE CHR$(0, 71)          'home
                 x% = 1
                 y% = 24
                 EXIT DO
              CASE CHR$(0, 79)          'end
                 x% = linecnt% - 24
                 y% = linecnt% + 1
                 EXIT DO
              CASE CHR$(0, 72)          'up
                 DECR x%
                 DECR y%
                 EXIT DO
              CASE CHR$(0, 73)          'Pg up
                 x% = x% - 24
                 y% = y% - 24
                 EXIT DO
              CASE CHR$(0, 80)          'down
                 INCR x
                 INCR y
                 EXIT DO
              'Pg down, SPACE, TAB
              CASE CHR$(0, 81), CHR$(32), CHR$(9)
                 x% = x% + 24
                 y% = y% + 24
                 EXIT DO
              CASE CHR$(27)             ' Esc quit
                 quit% = 1
                 EXIT DO
              CASE CHR$(0, 77)          'right
                 INCR shft%
                 EXIT DO
              CASE CHR$(0, 75)          'left
                 DECR shft%
                 IF shft% < 1 THEN shft% = 1
                 EXIT DO
              CASE ELSE
                 EXIT DO
           END SELECT
        LOOP
        IF quit% = 1 THEN EXIT DO
     LOOP
  END SUB
'------------------------------------------------------------------------
  SUB display (aline$, shft%)
' display a line of code

     COLOR 7,1
     comment% = 0
     quote% = 0
     el% = LEN(aline$) + 1
     FOR cp% = shft% TO shft% + 79
        ltr$ = MID$(aline$, cp%, 1)
        IF cp% < el% THEN
           IF comment% = 0 THEN
              IF ltr$ = CHR$(34) THEN
                 IF quote% = 0 THEN
                    quote% = 1
                    COLOR 13,1
                 ELSE
                    quote% = 3
                 END IF
              ELSEIF quote% = 0 AND INSTR(ltr$, ANY ":,;, ,(,),+,-,="+ CHR$(9)) THEN
                 COLOR 7,1
                 word% = 0
              ELSE
                 IF word% = 0 AND quote% = 0 THEN
                    eow% = INSTR(cp%, aline$, ANY ":,;, ,(,),+,-,="+CHR$(9))
                    IF eow% = 0 AND cp% =< LEN(aline$) THEN eow% = LEN(aline$) + 1
                    testkey$ = MID$(aline$, cp%, eow% - cp%)
                    word% = 1
                    IF LEFT$(testkey$,1) = "'" OR LCASE$(testkey$) = "rem" THEN comment% = 1: COLOR 3, 1
                    FOR n% = 1 TO numk%
                       IF LCASE$(testkey$) = keyword$(n%) THEN
                          COLOR colour%(n%), 1
                          EXIT FOR
                       END IF
                    NEXT
                 END IF
              END IF
           END IF
           IF ltr$ = CHR$(9) THEN
              PRINT TAB(8*(POS(0)/8 + 1))
           ELSE
              IF POS(0) < 80 THEN PRINT ltr$;
              IF quote% = 3 THEN quote% = 0: COLOR 7,1
           END IF
        ELSE
           IF POS(0) < 80 THEN PRINT " ";
        END IF
     NEXT
  END SUB
'------------------------------------------------------------------------
  SUB config
'reads the DATA statements

     DIM keyword$(numk%), colour%(numk%)
     FOR n% = 1 TO numk%
        READ keyword$(n%)
        READ colour%(n%)
     NEXT
  END SUB
'------------------------------------------------------------------------
  SUB help
'Help window

     Savescreen helpscreen$,5,16,15,65,1
     Win 2,"Help !",5,16,15,65,14,3
     COLOR 1,3
     LOCATE 6,31: PRINT "BASVIEW source viewer";
     COLOR 0,3
     LOCATE 7,18: PRINT "Navigation:";
     LOCATE 8,18: PRINT "Up/Down arrow keys     move one line";
     LOCATE 9,18: PRINT "PgUp/PgDn(or SPACE)    move one screen";
     LOCATE 10,18: PRINT "Left/Right arrow keys  shift 5 columns";
     LOCATE 11,18: PRINT "Home                   goes to top of file";
     LOCATE 12,18: PRINT "End                    goes to bottom of file";
     COLOR 4,3
     LOCATE 13,18: PRINT "F2 asks for search string, F3 repeats search";
     LOCATE 14,18: PRINT "Esc Exits the viewer";
     WHILE INKEY$ = ""
     WEND
     Restorescreen helpscreen$,5,16
  END SUB
'------------------------------------------------------------------------
' Sub Program to handle window input
'  (Displays existing value of variable and allows changes to it)
'  (Terminates by Enter,Esc,FunKey,UP/Down Arrow etc)
'   Parameters are:
'   srow%,scol% - location of start of string input
'         ilen% - maximum number of characters to accept
'           ip$ - variable to accept input into
'      retcode% - records which terminating key was pressed by user
'         posn% - cursor location when terminating key pressed
' =======================================================================
  Sub Getinput (Srow%, Scol%, Ilen%, Ip$, Retcode%, Posn%)
     B$ = Space$(Ilen%)
     Posn% = 1
     Retcode% = 0
     While Retcode% < 1
        Locate Srow%, Scol%: Print Left$(Ip$ + B$, Ilen%)
        Locate Srow%, Scol% - 1 + Posn%, 1, 7, 7
        A$="": While A$ = "": A$ = Inkey$: Wend
        Select Case A$
           Case " " To Chr$(255)        'Normal Key
              If Posn% > Ilen% Then Posn% = Ilen%
              If Posn% <= Len(Ip$) Then Mid$(Ip$, Posn%, 1) = A$ Else Ip$ = Ip$ + A$
              Posn% = Posn% + 1: If Posn% > Ilen% Then Posn% = Ilen%

           Case Chr$(8)                 'Backspace
              If Posn% > 1 Then
                 Temp1$ = Left$(Ip$, Posn% - 2)
                 Temp2$ = Mid$(Ip$, Posn%)
                 Ip$ = Temp1$ + Temp2$
                 Posn% = Posn% - 1
              End If
           Case Chr$(0) + Chr$(83)      'Delete Key
              Temp1$ = Left$(Ip$, Posn% - 1)
              Temp2$ = Mid$(Ip$, Posn% + 1)
              Ip$ = Temp1$ + Temp2$
           Case Chr$(0) + Chr$(75)      'Leftarrow
              Posn% = Posn% - 1: If Posn% < 1 Then Posn% = 1
           Case Chr$(0) + Chr$(77)      ' Rightarrow
              Posn% = Posn% + 1: If Posn% > Len(Ip$) Then Posn% = Len(Ip$)

           Case Chr$(27)                'Escape
              Retcode% = 99
           Case Chr$(13)                'Return
              Retcode% = 98
           Case Chr$(0) + Chr$(80)      'Downarrow
              Retcode% = 97
           Case Chr$(0) + Chr$(72)      'Uparrow
              Retcode% = 96
           Case Chr$(0) + Chr$(59)      'F1
              Retcode% = 1
           Case Chr$(0) + Chr$(60)      'F2
              Retcode% = 2
           Case Chr$(0) + Chr$(61)      'F3
              Retcode% = 3
           Case Chr$(0) + Chr$(62)      'F4
              Retcode% = 4
           Case Chr$(0) + Chr$(63)      'F5
              Retcode% = 5
           Case Chr$(0) + Chr$(64)      'F6
              Retcode% = 6
           Case Chr$(0) + Chr$(65)      'F7
              Retcode% = 7
           Case Chr$(0) + Chr$(66)      'F8
              Retcode% = 8
           Case Chr$(0) + Chr$(67)      'F9
              Retcode% = 9
           Case Chr$(0) + Chr$(68)      'F10
              Retcode% = 10
           Case Else                    ' All Other Keys
              Beep
        End Select
     Wend
  End Sub
'--------------------------------------------------------------------------
' Sub Win(t%,Title$,yb%,xb%,ye%,xe%,ct%,cb%)
' Parameters:
' t%               - the window type,
' Title$           - window title,
' yb%,xb%,ye%,xe%  - the window coordinates,
'             ct%  - text color,
'             cb%  - background color of the window;
'--------------------------------------------------------------------------
  SUB Win(t%,Title$,yb%,xb%,ye%,xe%,ct%,cb%)
'
     OldColor% = pbvScrnTxtAttr         ' Internal PB variable
'
     SELECT CASE t%                     ' Window types
'                                       ' (you can make as much types,
'                                       '  as you want):
        CASE 1
           'ÚÄ´ÃÄÄÄÄ¿ ´Ã
           a%=218:b%=196:c%=191:i%=180:j%=195
           h%=179: :d%=179              '³   1   ³
           g%=192:f%=196:e%=217         'ÀÄÄÄÄÄÄÄÙ
        CASE 2
           'É͵ÆÍÍÍÍ» µÆ
           a%=201:b%=205:c%=187:i%=181:j%=198
           h%=186: :d%=186              'º   2   º
           g%=200:f%=205:e%=188         'ÈÍÍÍÍÍÍͼ
        CASE ELSE
           a%=032:b%= a%:c%= a%         '
           h%= a%: :d%= a%              ' Blanks only
           g%= a%:f%= a%:e%= a%         '
     END SELECT
     COLOR ct%,cb%
     LOCATE yb%,xb%

      ' draw the window
       ' top line with title, if provided
     IF LEN(Title$) THEN
        Title$ = " " + Title$ + " "
        x% = ((xe% - xb%) - 1) - (LEN(Title$) + 2)
        y% = x% \ 2
        z% = x% - y%
        Ti$ = STRING$(y%,CHR$(b%)) + CHR$(i%) + Title$ + CHR$(j%) + STRING$(z%,CHR$(b%))
        PRINT CHR$(a%) + Ti$ + CHR$(c%);
     ELSE
        PRINT CHR$(ac%) + W$ + CHR$(c%);
     END IF
  ' middle
     FOR i%=yb%+1 TO ye%-1
        LOCATE i%,xb% : PRINT CHR$(h%)+ SPACE$(xe%-xb%-1) +CHR$(d%)
     NEXT
       ' bottom
     LOCATE ye%,xb% : PRINT CHR$(g%)+REPEAT$(xe%-xb%-1,CHR$(f%))+CHR$(e%)

     FOR i%=yb%+1 TO ye%+1
        PutAttribute xe%+1,i%,7,0       ' Making
     NEXT                               ' shadows
     FOR i%=xb%+1 TO xe%+1              '
        PutAttribute i%,ye%+1,7,0       '
     NEXT
     ct%=OldColor% AND 15               ' restore colors
     cb%=OldColor%\16
     COLOR ct%,cb%
  END SUB
'-------------------------------------------------------------------------
' Sub SaveScreen(w$,yb%,xb%,ye%,xe%,sh%)
' Parameters:
' w$               - string to save window in,
' yb%,xb%,ye%,xe%  - the window coordinates,
'             sh%  - shadow,
'
'-------------------------------------------------------------------------
  SUB SaveScreen(w$,yb%,xb%,ye%,xe%,sh%) PUBLIC
     DIM temp AS BYTE PTR
     DIM WinPtr AS BYTE PTR
     DIM TextPtr AS BYTE PTR
     lx% = (xe% - xb% + 1) * 2
     ly% = ye% - yb% + 1
     IF sh% THEN
        INCR lx%,2
        INCR ly%
     END IF
     l$ = RIGHT$(" " + STR$(lx%), 3 )
     w$ = l$ + SPACE$( lx% * ly% )
     WinPtr = PBVSCRNBUFF + (yb%-1)*160 + (xb%-1)*2
     TextPtr = STRPTR32(w$) + 3
     FOR i%=1 TO ly%
        temp = WinPtr
        FOR k%=1 TO lx%
           @TextPtr = @temp
           INCR TextPtr
           INCR temp
        NEXT
        INCR WinPtr,160
     NEXT
  END SUB
'-------------------------------------------------------------------------
' Sub RestoreScreen(w$,yb%,xb%)
' Parameters:
' w$               - string holding saved window data,
' yb%,xb%,ye%,xe%  - the window coordinates,
'-------------------------------------------------------------------------
  SUB RestoreScreen(w$,yb%,xb%) PUBLIC
     DIM temp AS BYTE PTR
     DIM WinPtr AS BYTE PTR
     DIM TextPtr AS BYTE PTR
     l$ = LEFT$(w$,3)
     w$ = LTRIM$(w$,l$)
     lx% = VAL(l$)
     ly% = LEN(w$) \ lx%
     TextPtr = STRPTR32(w$)
     WinPtr = PBVSCRNBUFF + (yb%-1)*160 + (xb%-1)*2
     FOR i%=1 TO ly%
        temp = WinPtr
        FOR k%=1 TO lx%
           @temp = @TextPtr
           INCR TextPtr
           INCR temp
        NEXT
        INCR WinPtr,160
     NEXT
  END SUB

'--------------------------------------------------------------------------
  SUB PutAttribute(x%,y%,t%,b%)         ' Puts attribute byte to video memory
     LOCAL c%                           ' directly to Colomn, Row position
     c% = b%*16+t%                      '
     DEF SEG = &hb800                   ' NOTE: This is system depending !
     POKE 160*(y%-1)+x%+x%-1,c%
     DEF SEG
  END SUB
'--------------------------------------------------------------------------
  DATA if,14,then,14,end,14,else,14,for,14,next,14,elseif,14,while,14,wend,14,do,14,loop,14,until,14,case,14,select,14,to,14,incr,11,decr,11,print,11,line,11,color,11,declare,11,dim,11,locate,11,delay,11,cls,11,shared,11,call,11,open,11
  DATA input,11,output,11,as,11,get,11,chr$,11,mid$,11,str$,11,left$,11,right$,11,sub,15,function,15,$alias,10,$code,10,$com,10,$compile,10,$cpu,10,$debug,10,$dim,10,$dynamic,10,$error,10,$event,10,$float,10,$huge,10,$if,10,$else,10,$endif,10
  DATA $include,10,$inline,10,$lib,10,$link,10,$optimize,10,$option,10,$segment,10,$sound,10,$stack,10,$static,10,$string,10,abs,11,absolute,11,access,11,and,11,any,11,append,11,array,11,asc,11,ascend,11,ascii,11,asm,11,atn,11,attrib,11,base,11
  DATA beep,11,bin$,11,binary,11,bit,11,bits,11,bload,11,bsave,11,ceil,11,chain,14,chdir,11,chdrive,11,cint,11,clng,11,cqud,11,csng,11,cdbl,11,cext,11,cfix,11,cbcd,11,cbyt,11,cwrd,11,cdwd,11,circle,11,clear,11,close,11,codeptr,11,codeseg,11
  DATA collaate,11,color,11,com,11,command$,11,common,11,cos,11,csrlin,11,curdir$,11,cvi,11,cvl,11,cvq,11,cvs,11,cvd,11,cve,11,cvf,11,cvb,11,cvbyt,11,cvdwd,11,cvwrd,11,cvmd,11,cvms,11,data,11,date$,11,def,11,deflng,11,defqud,11,defsng,11
  DATA defdbl,11,deefext,11,deffix,11,defbcd,11,defstr,11,defflx,11,delete,11,descend,11,dir$,11,draw,11,dynamic,11,ems,11,endmem,11,environ,11,environ$,11,eof,11,eqv,11,eradr,11,erase,11,erdev,11,erdev$,11,erl,11,err,11,error,11,errtest,11
  DATA execute,11,exit,14,exp,11,exp10,11,exp2,11,external,11,extract$,11,far,11,field,11,fileattr,11,files,11,fixdigits,11,flexchr$,11,flush,11,fn,11,step,11,frac,11,fre,11,freefile,11,from,11,get$,11,gosub,11,goto,11,hex$,11,imp,11,in,11
  DATA inkey$,11,inp,11,input$,11,insert,11,instat,11,instr,11,int,11,interrupt,11,ioctl,11,ioctl$,11,isfalse,11,istrue,11,iterate,11,key,11,kill,11,lbound,11,lcase$,11,left$,11,len,11,let,11,line,11,list,11,loc,11,local,11,locate,11,lock,11
  DATA lof,11,log,11,log10,11,log2,11,lpos,11,lprint,11,lset,11,ltrim$,11,map,11,max,11,max$,11,max%,11,mempack,11,memset,11,mid$,11,min,11,min$,11,min%,11,mkdir,11,mki$,11,mkl$,11,mkq$,11,mks$,11,mkd$,11,mke$,11,mkf$,11,mkb$,11,mkbyt$,11
  DATA mkwrd$,11,mkdwd$,11,mkmd$,11,mkms$,11,mtimer,11,multiplex,11,name,11,not,11,oct$,11,off,11,on,11,open,11,option,11,or,11,out,11,output,11,paint,11,palette,11,peek,11,peek$,11,peeki,11,peekl,11,pen,11,play,11,pmap,11,point,11
  DATA poke,11,poke$,11,pokei,11,pokel,11,popup,11,pos,11,preset,11,pset,11,public,11,put,11,put$,11,quiet,11,random,11,randomize,11,read,11,redim,11,reg,11,remove$,11,repeat$,11,replace,11,reset,11,restore,11,resume,11,return,11,right,11
  DATA rmdir,11,rnd,11,rotate,11,round,11,rset,11,rtrim$,11,run,11,scan,11,screen,11,seek,11,seg,11,setmem,11,sgn,11,shared,11,shell,11,shift,11,signed,11,sin,11,sleep,11,sort,11,sound,11,space$,11,spc,11,sqr,11,static,11,stick,11,stop,11
  DATA str$,11,strig,11,string$,11,strptr,11,strseg,11,stuff,11,swap,11,system,11,tab,11,tagarray,11,tally,11,tan,11,time$,11,timer,11,troff,11,tron,11,type,11,ubound,11,ucase,11,ucase$,11,uevent,11,union,11,unlock,11,using,11,using$,11,val,11
  DATA varptr,11,varptr$,11,varseg,11,verify,11,view,11,wait,11,width,11,window,11,with,11,write,11,xor,11,integer,11,long,11,quad,11,byte,11,word,11,dword,11,single,11,double,11,ext,11,fix,11,bcd,11,string,11,flex,11,byval,11,defint,11