'===========================================================================
' Subject: CHOOSING FILES                     Date: 06-17-96 (09:41)       
'  Author: Alexander Podkolzin                Code: PB32                   
'  Origin: APP@nw.sbank.e-burg.su           Packet: PB.ABC
'===========================================================================
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' PowerBASIC 3.2+ only.                                                    '
' Demo program for choosing files.  Use it as you want...                  '
' Author: Alexander Podkolzin <APP@nw.sbank.e-burg.su>                     '
' Special thanks to Eric Olson for his public domain SUBs SaveScreen and   '
' RestoreScreen (I'v rewrote them using pointers).                         '
' Thank you for paying attention to that demo programme!                   '
'                                                                          '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' You will find here some new functions and subs of mine
' (demo versions)...
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
DECLARE _
  FUNCTION ChFile(mask$,wt%,xb%,yb%,xe%,ye%,ct%,cb%,ctn%,cbn%) _
  AS STRING
DECLARE _
  FUNCTION GetTextLine(txt$(),wt%,xb%,yb%,xe%,ye%,ct%,cb%,ctn%,cbn%,init%) _
  AS INTEGER
DECLARE SUB Numerer(nlines%,lpage%,begy%,endy%)
DECLARE SUB PutAttribute(x%,y%,t%,b%)
DECLARE SUB PutString(x%,y%,st$)
DECLARE SUB RestoreScreen(w$,xb%,yb%)
DECLARE SUB SaveScreen(w$,xb%,yb%,xe%,ye%,shadow%)
DECLARE SUB Win(t%,xb%,yb%,xe%,ye%,ct%,cb%)
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  DEFINT a-z
'
  PRINT CURDIR$
'
  s$ = ChFile("*.*",1,10,3,31,20,0,7,14,0)
'
  COLOR 14,0
  LOCATE 24,1
  IF s$<>"" THEN
     PRINT "You'v chosen file: ";s$
  ELSE
     PRINT "Cancelled."
  END IF
'
  END
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  FUNCTION ChFile(mask$, _
                  wint%, _            ' win type,
                  xb%,yb%,xe%,ye%, _  ' win's coordinates,
                  ct%,cb%, _          ' win's colors,
                  ctn%,cbn%) _        ' cursor bar colors.
           PUBLIC AS STRING
'
     DIM Names(512) AS STRING
'
     Curd$ = CURDIR$
     CALL SaveScreen(wsh$,xb%,yb%,xe%,ye%,1)
     k%=1
     DO
        Current% = 1
        IF LEN(CURDIR$)>3 THEN
           Names(1)=".."+" ]"
           INCR k%
        END IF
'
        f$=DIR$("*.*",16)         ' Looking for DIRs
        IF f$<>"" THEN
           IF ATTRIB(f$)=16 THEN
              Names(k%)=UCASE$(f$)+" ]"
              INCR k%
           END IF
           DO
              f$=DIR$
              IF f$="" THEN EXIT LOOP
              IF ATTRIB(f$)=16 THEN
                 Names(k%)=UCASE$(f$)+" ]"
                 INCR k%
              END IF
           LOOP
        END IF
        FOR i%=1 TO k%-1
           f$=Names(i%)
           l%=LEN(f$)
           IF l%<16 THEN
              REPLACE "]" WITH STRING$(14-l%," ")+"<DIR>" IN Names(i%)
           END IF
        NEXT i%
'
        nd% = k% - 1
'
        ARRAY SORT Names() FOR nd%
'
        m% = LEN(CURDIR$)
        IF m% = 3 THEN m% = 2
        n% = LEN(OldDir$) - m%
        IF INSTR(OldDir$,CURDIR$) <> 0 AND n% > 0 THEN
           s$ = RIGHT$(OldDir$,n% - 1)
           FOR i%=1 TO nd%
              IF s$ = RTRIM$(LEFT$(Names(i%),12)) THEN
                 Current% = i%
                 EXIT FOR
              END IF
           NEXT
        END IF
'
        f$=DIR$(mask$)            ' Looking for files
        IF f$<> "" THEN
           Names(k%)=LCASE$(f$)
           INCR k%
           DO
              f$=DIR$
              IF f$="" THEN EXIT LOOP
              Names(k%)=LCASE$(f$)
              INCR k%
           LOOP
        END IF
'
        ARRAY SORT Names(nd% + 1) FOR k% - nd% - 1
'
        k% = GetTextLine( Names(),wint%,xb%,yb%,xe%,ye%, _
                          ct%,cb%,ctn%,cbn%,Current% )
'
        IF k% < 0 THEN
           chfile$ = ""
           EXIT LOOP
        END IF
'
        IF k%=1 AND LEN(CURDIR$) > 3 THEN
           OldDir$ = CURDIR$
           CHDIR ".."
           REDIM Names(512) AS STRING
           k%=1
        ELSEIF INSTR(Names(k%),"<DIR>") THEN
           CHDIR REMOVE$(Names(k%),"<DIR>")
           REDIM Names(512) AS STRING
           k%=1
        ELSE
           c$ = CURDIR$
           IF LEN(c$)=3 THEN c$=LEFT$(c$,2)
           s$ = c$ + "\" + Names(k%)
           ChFile$ = s$
           EXIT LOOP
        END IF
'
     LOOP
'
     CALL RestoreScreen(wsh$,xb%,yb%)
     CHDIR Curd$
  END FUNCTION
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  FUNCTION GetTextLine%( txt$(), _' text array,
     twin%, _                     ' win's type,
     xb%, yb%, xe%, ye0%, _       ' win's coordinates,
     ct%,cb%, _                   ' win's colors,
     ctn%,cbn%, _                 ' cursor bar colors
     init% _                      ' initial position of cursor bar.
     ) _
     PUBLIC
'
     OldX% = POS(0)               ' Saving parameters
     OldY% = CSRLIN               '
     COLOR ct%,cb%                '
'
     Enter$=CHR$(13)              ' Only for beauty of our code,
     Esc$ = CHR$(27)              ' as it's rather difficult to
     Home$ = CHR$(0,71)           ' understand such lines as:
     PgUp$ = CHR$(0,73)           ' IF RIGHT$(s$,1) = "G" THEN ...
     EndKey$ = CHR$(0,79)         ' then:
     PgDn$ = CHR$(0,81)           ' IF s$ = Home$ THEN ...
     Up$ = CHR$(0,72)             '
     Down$ = CHR$(0,80)           '
'
     FOR i%=1 TO UBOUND(txt$())   ' max lines in text array
        IF LEN(txt$(i%))=0 THEN EXIT FOR
     NEXT i%
     nlines%=i%-1
     IF nlines%<ye0%-yb%-1 THEN
        ye%=yb%+nlines%+1
     ELSE
        ye%=ye0%
     END IF
     lpage%=ye%-yb%-1
     CALL win(twin%,xb%,yb%,xe%,ye%,ct%,cb%)
     begy%=init%
     Cur%=init% - begy% + 1
     endy%=MIN(lpage%,nlines%)
     DO                           ' begy% - first line to show,
        GOSUB ShowText            ' endy% - last line to show (array)
        GOSUB ShowCursorBar
        IF nlines%<1 THEN EXIT LOOP
        WHILE NOT INSTAT: WEND
        k$=INKEY$
        SELECT CASE k$
           CASE Esc$
              cur% = 0
              begy%= 0
              EXIT LOOP
           CASE Enter$
              EXIT LOOP
           CASE Home$
              GOSUB HideCursorBar
              Cur% =1
              begy%=1
           CASE EndKey$
              GOSUB HideCursorBar
              cur%=ye%-yb%-1
              begy%=Nlines%-ye%+yb%+2
           CASE Up$
              IF cur%>1 THEN
                 GOSUB HideCursorBar
                 DECR cur%
              ELSE
                 begy%=begy%-1
              END IF
           CASE Down$
              IF cur%<lpage% THEN
                 GOSUB HideCursorBar
                 INCR cur%
              ELSE
                 begy%=begy%+1
              END IF
           CASE PgUp$
              begy%=begy%-lpage%
           CASE PgDn$
              begy%=begy%+lpage%
           CASE ELSE
              k$=""
        END SELECT
     LOOP
     Gt%=begy%+cur%-1
     GetTextLine% = Gt%
     LOCATE oldy%,oldx%
     EXIT FUNCTION
'
'

ShowText:
     CALL Numerer(nlines%,lpage%,begy%,endy%)
     GOSUB MakeRuler
     FOR i%=begy% TO endy%
        PutString xb%+2,yb%+i%-begy%+1,_
        LEFT$(txt$(i%)+SPACE$(xe%-xb%+1),xe%-xb%-3)
     NEXT i%
     RETURN
'
'

ShowCursorBar:
     FOR i%=xb%+1 TO xe%-1
        PutAttribute i%,yb%+cur%,ctn%,cbn%
     NEXT
     RETURN
'
'

HideCursorBar:
     FOR i%=xb%+1 TO xe%-1
        PutAttribute i%,yb%+cur%,ct%,cb%
     NEXT
     RETURN
'
'

MakeRuler:
     FOR i%=yb%+1 TO ye%-1
        PutAttribute xe%,i%,ct%,cb%
        PutString xe%,i%,CHR$(177)
     NEXT
     k%=((begy%+cur%-1)/nlines%)*(ye%-yb%-1)
     IF k%=0 THEN k%=1
     PutString xe%,yb%+k%,CHR$(8)
     RETURN
  END FUNCTION
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Numerer "normalizes" begy% and endy%        <-  very usefull function!
'
  SUB Numerer(nlines%,lpage%,begy%,endy%)
     IF nlines%<=lpage% THEN
        begy%=1
        endy%=nlines%
        EXIT SUB
     END IF
     IF begy%<1 THEN
        begy%=1
        endy%=begy%+lpage%-1
        EXIT SUB
     END IF
     IF begy%+lpage%-1>=nlines% THEN
        endy%=nlines%
        begy%=nlines%-lpage%+1
        EXIT SUB
     END IF
     endy%=begy%+lpage%-1
  END SUB
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  SUB Win(t%,xb%,yb%,xe%,ye%,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   ' Single frame,
           h%=179:      :d%=179   '
           g%=192:f%=196:e%=217   '
        CASE 2
           a%=201:b%=205:c%=187   ' double frame,
           h%=186:      :d%=186   '
           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% : PRINT CHR$(a%)+REPEAT$(xe%-xb%-1,CHR$(b%))+CHR$(c%)
     FOR i%=yb%+1 TO ye%-1
        LOCATE i%,xb% : PRINT CHR$(h%)+ SPACE$(xe%-xb%-1) +CHR$(d%)
     NEXT
     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%,8,0 ' Making
     NEXT                         ' shadows
     FOR i%=xb%+1 TO xe%+1        '
        PutAttribute i%,ye%+1,8,0
     NEXT
     ct%=OldColor% AND 15         ' restore colors
     cb%=OldColor%\16
     COLOR ct%,cb%
  END SUB
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  SUB PutAttribute(x%,y%,t%,b%)   ' Puts attribute byte to video memory
     DIM Cell AS BYTE PTR
     Cell = PBVSCRNBUFF + (y% - 1)*160 + (x% - 1)*2 + 1
     @Cell = b%*16 + t%
  END SUB
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  SUB PutString(x%,y%,st$)        ' Puts string to video memory
     DIM Cell AS BYTE PTR
     DIM TextPtr AS BYTE PTR
'
     TextPtr = STRPTR32( st$ )
     Cell = PBVSCRNBUFF + ( y% - 1 ) * 160 + ( x% - 1 ) * 2
     FOR i% = 1 TO LEN( st$ )
        @Cell = @TextPtr
        INCR TextPtr
        INCR Cell, 2
     NEXT
  END SUB
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  SUB SaveScreen(w$,xb%,yb%,xe%,ye%,sh%)
     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$,xb%,yb%)
     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
'   w$ = ""
  END SUB
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'