Author Topic: Record based file indexing  (Read 4890 times)

Offline John

  • Forum Support / SB Dev
  • Posts: 3510
    • ScriptBasic Open Source Project
Record based file indexing
« on: August 30, 2015, 03:33:26 AM »
I noticed on the PowerBASIC forum a post about a converted PBDOS example that creates an index to sort DBF or record based files. I'm going to try and convert it to Script BASIC and use my ANSI include module for screen control.

I would be great if others BASIC language users might give a conversion a try.

Code: ScriptBasic
  1.  (Actually PBDOS code)
  2.  
  3. 'PB 3.5 program for DOS to create,browse,append,edit and index DBF tables.
  4. 'Improved version of the original PB 3.5 program. Manuel Valdes - Ago.2015
  5. 'Indexing is done using a variant of Michael Mattias' code posted here
  6. 'http://www.powerbasic.com/support/pbforums/showthread.php?t=59643
  7.  
  8. COLOR 0,7
  9. CLS
  10. $STACK 4048
  11.  
  12. DIM CONT(10000) AS STRING*1
  13. DIM OBJECTIVE(100) AS STRING*1
  14. DIM FIELD_NAME$(200,11),FLN$(200),FIELD_TYPE$(200),LENGTH$(200),DECI$(200),ASTR$(255)
  15. DIM L$(80)
  16.  
  17. SW%=1
  18. NOREG&=0
  19. N%=1
  20. P&=1
  21. GOSUB STATUS_BAR
  22. COLOR 7,4
  23. LOCATE 24,10:INPUT "",ARCH$
  24. IF ARCH$="" THEN
  25.  COLOR 7,0
  26.  CLS
  27.  END
  28. END IF
  29. ARCH$=UCASE$(ARCH$)
  30. IF INSTR(ARCH$,".")=0 THEN ARCH$=ARCH$+".DBF"
  31. COLOR 0,7
  32. OPEN ARCH$ FOR BINARY AS #1
  33. IF LOF(1)=0 THEN
  34.  CLOSE 1
  35.  KILL ARCH$
  36.  CLS
  37.  GOSUB NEW_FILE
  38.  IF LOF(1)=0 THEN
  39.   CLOSE 1
  40.   KILL ARCH$
  41.   CLS
  42.   END
  43.  END IF
  44. END IF
  45. GET$ #1,4,MARK$
  46. GET #1,4,NOREG&
  47. GET #1,8,HEAD_LEN%
  48. GET #1,10,REG_LEN%
  49. K%=(HEAD_LEN%-32)\32
  50. GET$ #1,20,TEMP$
  51. FOR J%=1 TO K%
  52.  FLN$(J%)=""
  53.  FOR I%=1 TO 11
  54.   GET$ #1,1,FIELD_NAME$(J%,I%)
  55.   FLN$(J%)=FLN$(J%)+FIELD_NAME$(J%,I%)
  56.  NEXT
  57.  GET$ #1,1,FIELD_TYPE$(J%)
  58.  GET$ #1,4,TEMP$
  59.  GET$ #1,1,LENGTH$(J%)
  60.  GET$ #1,1,DECI$(J%)
  61.  GET$ #1,14,TEMP$
  62.  FOR I%=2 TO 11
  63.   IF FIELD_NAME$(J%,I%-1) = CHR$(0) THEN FIELD_NAME$(J%,I%) = CHR$(0)
  64.  NEXT
  65. NEXT
  66. J%=0
  67. JP%=0
  68. IF NOREG&=0 THEN
  69.  CH$=CHR$(13)
  70.  WHILE CH$=CHR$(13)
  71.   GOSUB ADD_IT
  72.   GOSUB EDIT_IT
  73.  WEND
  74.  IF CH$<>CHR$(13) THEN DECR NOREG&
  75.  SEEK #1,HEAD_LEN%+NOREG&*REG_LEN%
  76.  PUT$ #1,CHR$(26)
  77.  SEEK #1,4
  78.  PUT$ #1,MKL$(NOREG&)
  79. END IF
  80. N&=1
  81. E&=1
  82. GOSUB CLEAR_SCR
  83. DO
  84.  IF NOREG&>0 THEN GOSUB BROWSE_IT
  85.  DO UNTIL INSTAT
  86.  LOOP
  87.  O$=UCASE$(INKEY$)
  88.  SELECT CASE O$
  89.   CASE CHR$(27)
  90.    EXIT
  91.   CASE CHR$(65) 'A_ppend
  92.   CH$=CHR$(13)
  93.    WHILE CH$=CHR$(13)
  94.     GOSUB ADD_IT
  95.     GOSUB EDIT_IT
  96.    WEND
  97.    IF CH$<>CHR$(13) THEN
  98.     DECR NOREG&
  99.     SEEK #1,HEAD_LEN%+NOREG&*REG_LEN%
  100.     PUT$ #1,CHR$(26)
  101.     SEEK #1,4
  102.     PUT$ #1,MKL$(NOREG&)
  103.    END IF
  104.    N&=1
  105.    GOSUB CLEAR_SCR
  106.   CASE CHR$(83) 'S_earch
  107.   P&=1
  108.    GOSUB RECU
  109.    GOSUB SEARCH_IT
  110.   CASE CHR$(82) 'R_epeat search
  111.   IF L%>1 THEN GOSUB SEARCH_IT
  112.   CASE CHR$(0,80)
  113.    IF E&<MIN(NOREG&,18) THEN
  114.     INCR E&
  115.    ELSE
  116.     INCR N&
  117.    END IF
  118.   CASE CHR$(71)   'G_o to record #
  119.   LOCATE 23,1
  120.    INPUT "รน Go to Record No. ",R$
  121.    N&=VAL(R$)
  122.    LOCATE 23,1
  123.    PRINT SPC(78);
  124.   CASE CHR$(0,72) 'Arrow Up
  125.   IF E&>1 THEN
  126.     DECR E&
  127.    ELSE
  128.     DECR N&
  129.    END IF
  130.   CASE CHR$(0,73) 'Page Up
  131.   N&=N&-18
  132.   CASE CHR$(0,81) 'Page Down
  133.   N&=N&+18
  134.   CASE CHR$(69)   'E_dit
  135.   GOSUB CLEAR_SCR
  136.    DO
  137.     GOSUB EDIT_IT
  138.     IF CH$=CHR$(27) THEN EXIT
  139.    LOOP
  140.    GOSUB CLEAR_SCR
  141.    'N&=1
  142.  CASE CHR$(0,77) 'Arrow Right
  143.   INCR JP%
  144.    IF JP%=K% THEN JP%=K%-1
  145.   CASE CHR$(0,75) 'Arrow Left
  146.   DECR JP%
  147.    IF JP%<0 THEN JP%=0
  148.   CASE CHR$(0,84) 'Control Arrow Left
  149.   JP%=K%-1
  150.   CASE CHR$(0,83)
  151.    JP%=0
  152.   CASE CHR$(0,71) 'First Record
  153.   N&=1
  154.    P%=1
  155.    E&=1
  156.   CASE CHR$(0,79) 'Last Record
  157.   N&=1+NOREG&-R%
  158.    E&=18
  159.   CASE CHR$(0,59)
  160.    GOSUB HELP
  161.   CASE CHR$(0,60) 'F2
  162.   GOSUB INDEX
  163.   CASE CHR$(0,61) 'Reverse Order  F3
  164.   IF FLG%=1 THEN
  165.     FLG%=2
  166.    ELSEIF FLG%=2 THEN
  167.     FLG%=1
  168.    END IF
  169.   CASE CHR$(0,62) 'F4
  170.   GOSUB DELETE_RECORD
  171.   CASE CHR$(0,63) 'F5
  172.   GOSUB PACK
  173.   CASE CHR$(0,64)
  174.    CALL MENUTASK(2,2,12,K%,FLN$(),OP%)
  175.  END SELECT
  176.  IF N&>1+NOREG&-R% THEN N&=1+NOREG&-R%
  177.  IF N&<1 THEN N&=1
  178. LOOP
  179. CLOSE 1
  180. IF FLG%=1 THEN CLOSE 3
  181. COLOR 7,0
  182. CLS
  183. END
  184.  
  185. CLEAR_SCR:
  186.  FOR I%=1 TO 24
  187.   LOCATE I%,1:PRINT SPC(79);
  188.  NEXT
  189. RETURN
  190.  
  191. WRITE_IT:
  192.  IF FLG%=1 THEN
  193.   GET #3,4*(A&-1),RN&
  194.  ELSEIF FLG%=2 THEN
  195.   GET #3,4*(NOREG&-A&),RN&
  196.  ELSE
  197.   RN&=A&
  198.  END IF
  199.  SEEK #1,HEAD_LEN%+(RN&-1)*REG_LEN%
  200.  DEF SEG = VARSEG(CONT(1))
  201.  ADR%=VARPTR(CONT(1))
  202.  R$=PEEK$(ADR%,REG_LEN%)
  203.  PUT$ #1,R$
  204. RETURN
  205.  
  206. SUB FORM_INPUT(XF%,YF%,LF%)
  207.  SHARED CH$,CH1$,ASTR$()
  208.  L%=LF%
  209.  WHILE ASTR$(L%)=CHR$(32)
  210.   DECR L%
  211.  WEND
  212.  IF L%<1 THEN L%=1
  213.  PF%=L%
  214.  CH$=CHR$(32)
  215.  CH1$=CHR$(0)
  216.  DO
  217.   LOCATE YF%,XF%
  218.   FOR I%=1 TO LF%
  219.    IF I%=PF% THEN
  220.     COLOR 7,4
  221.    ELSE
  222.     COLOR 4,7
  223.    END IF
  224.    PRINT ASTR$(I%);
  225.   NEXT
  226.   DO UNTIL INSTAT
  227.   LOOP
  228.   CH$=INKEY$
  229.   IF LEN(CH$)=2 THEN
  230.    CH1$=(MID$(CH$,2,1))
  231.    IF CH1$=CHR$(75) THEN
  232.     IF PF%>1 THEN DECR PF%
  233.    ELSEIF CH1$=CHR$(77) THEN
  234.     IF PF%<LF% THEN INCR PF%
  235.     IF PF%>L% THEN INCR L%
  236.    ELSEIF CH1$=CHR$(83) THEN
  237.     FOR I%=PF% TO L%-1
  238.      ASTR$(I%)=ASTR$(I%+1)
  239.     NEXT
  240.     IF L%>=PF% THEN
  241.      ASTR$(L%)=CHR$(32)
  242.      DECR L%
  243.     END IF
  244.    END IF
  245.   ELSE
  246.    IF CH$=CHR$(8) THEN
  247.     FOR I%=PF% TO L%
  248.      ASTR$(I%-1)=ASTR$(I%)
  249.     NEXT
  250.     IF PF%>1 THEN DECR PF%
  251.     IF L%>1 THEN
  252.      ASTR$(L%)=CHR$(32)
  253.      DECR L%
  254.     END IF
  255.    ELSEIF CH$=CHR$(27) THEN
  256.     COLOR 0,7
  257.     EXIT
  258.    ELSEIF CH$=CHR$(13) THEN
  259.     'VOID
  260.   ELSEIF CH$>CHR$(30) THEN
  261.     IF L%<LF% THEN INCR L%
  262.     FOR I%=L% TO PF% STEP -1
  263.      ASTR$(I%)=ASTR$(I%-1)
  264.     NEXT
  265.     ASTR$(PF%)=CH$
  266.     LOCATE YF%,XF%+PF%
  267.     IF PF%<LF% THEN
  268.      PRINT CH$;
  269.      INCR PF%
  270.      CH$=CHR$(0)
  271.     END IF
  272.    END IF
  273.   END IF
  274.   IF CH$=CHR$(13) OR (INSTR(CHR$(72,80,73,81,119,117,60,61,62),CH1$) > 0) THEN EXIT
  275.  LOOP
  276.  COLOR 0,7
  277. END SUB
  278.  
  279. STATUS_BAR:
  280.  LOCATE 24,1
  281.  COLOR 7,4
  282.  PRINT STRING$(80,32);
  283.  LOCATE 24,3
  284.  PRINT "File : ";ARCH$
  285.  LOCATE 24,51
  286.  PRINT "ยบ  Reg. No. ";
  287.  PRINT USING "######";N&+E&-1;
  288.  PRINT "/";
  289.  PRINT USING "######";NOREG&;
  290.  PRINT "    ";
  291.  COLOR 0,7
  292. RETURN
  293.  
  294. RECU:
  295.  POREL%=1
  296.  LENGTH$(0)="0"
  297.  TEMP$=""
  298.  LOCATE 23,1
  299.  PRINT "รน Search:"
  300.  LOCATE 23,12
  301.  INPUT "",TEMP$
  302.  L%=LEN(TEMP$)
  303.  LOCATE 23,1
  304.  PRINT SPC(78);
  305.  LOCATE 23,1:PRINT "รน in Field : ";
  306.  OP%=1
  307.  CALL MENUTASK(2,2,12,K%,FLN$(),OP%)
  308.  IF FIELD_TYPE$(OP%)=CHR$(68) THEN
  309.   TEMP$=MID$(TEMP$,7,2)+MID$(TEMP$,4,2)+MID$(TEMP$,1,2)
  310.   L%=6
  311.  END IF
  312.  FOR I%=1 TO L%
  313.   OBJECTIVE(I%)=MID$(TEMP$,I%,1)
  314.  NEXT
  315. RETURN
  316.  
  317. READ_IT:
  318.  IF FLG%=1 THEN
  319.   GET #3,4*(A&-1),RN&
  320.  ELSEIF FLG%=2 THEN
  321.   GET #3,4*(NOREG&-A&),RN&
  322.  ELSE
  323.   RN&=A&
  324.  END IF
  325.  DEF SEG=VARSEG(CONT(1))
  326.  ADR%=VARPTR(CONT(1))
  327.  SEEK #1,HEAD_LEN%+(RN&-1)*REG_LEN%
  328.  GET$ #1,REG_LEN%,R$
  329.  POKE$ ADR%,R$
  330. RETURN
  331.  
  332. SEARCH_IT:
  333.  POREL%=1
  334.  FOR I%=1 TO OP%-1
  335.   POREL%=POREL%+ASC(LENGTH$(I%))
  336.  NEXT
  337.  POLIM%=ASC(LENGTH$(OP%))
  338.  IF OP%=0 THEN
  339.   POREL%=1
  340.   POLIM%=REG_LEN%
  341.  END IF
  342.  N&=P&
  343.  DO UNTIL Y%=1 OR N&=NOREG&
  344.   IF N&<NOREG& THEN
  345.    INCR N&
  346.    A&=(N&)
  347.    GOSUB READ_IT
  348.   END IF
  349.   COLOR 7,4
  350.   LOCATE 24,63
  351.   PRINT USING "######";N&
  352.   COLOR 0,7
  353.   H%=POREL%
  354.   Y%=0
  355.   WHILE Y%=0 AND H%<=POREL%+POLIM%
  356.    IF UCASE$(CONT(H%))=UCASE$(OBJECTIVE(1)) THEN
  357.     Y%=1
  358.     FOR J%=2 TO L%
  359.      IF UCASE$(CONT(H%+J%-1))<>UCASE$(OBJECTIVE(J%)) THEN Y%=0
  360.     NEXT
  361.    END IF
  362.    INCR H%
  363.   WEND
  364.  LOOP
  365.  IF Y%=1 THEN
  366.   BEEP
  367.   Y%=0
  368.  END IF
  369.  P&=N&
  370.  LOCATE 23,1
  371.  PRINT SPC(78)
  372.  CH$=CHR$(27)
  373. RETURN
  374.  
  375. INICIATE_IT:
  376.  OPEN "B",#1,ARCH$
  377.  PUT$ #1,CHR$(3,0,0,0)
  378.  PUT$ #1,MKL$(NOREG&)
  379.  HEAD_LEN%=(32*K%)+33
  380.  PUT$ #1,MKI$(HEAD_LEN%)
  381.  INCR REG_LEN%
  382.  PUT$ #1,MKI$(REG_LEN%)
  383.  PUT$ #1,STRING$(20,CHR$(0))
  384.  FOR J%=1 TO K%
  385.   FOR I%=1 TO 10
  386.    PUT$ #1,FIELD_NAME$(J%,I%)
  387.   NEXT
  388.   PUT$ #1,CHR$(0)
  389.   PUT$ #1,FIELD_TYPE$(J%)
  390.   PUT$ #1,STRING$(4,0)
  391.   PUT$ #1,LENGTH$(J%)
  392.   PUT$ #1,DECI$(J%)
  393.   PUT$ #1,STRING$(14,0)
  394.  NEXT
  395.  PUT$ #1,CHR$(13,26)
  396.  CLOSE 1
  397. RETURN
  398.  
  399. NEW_FILE:
  400.  GOSUB STATUS_BAR
  401.  PC%=1
  402.  K%=1
  403.  FOR I%=1 TO 11
  404.   FIELD_NAME$(1,I%)=CHR$(32)
  405.  NEXT
  406.  FIELD_TYPE$(1)=CHR$(32)
  407.  LENGTH$(1)=CHR$(0)
  408.  DECI$(1)=CHR$(0)
  409.  H%=0
  410.  PL%=1
  411.  R%=0
  412.  REG_LEN%=0
  413.  LOCATE 1,12:PRINT "No.   Field    Type  Len  Dec"
  414.  DO
  415.   FOR B%=1 TO 20
  416.    LOCATE B%+2,11
  417.    IF B%+H%>0 AND B%+H%<=K% THEN
  418.     PRINT USING "###";B%+H%;
  419.     PRINT "  ";
  420.     FOR I%=1 TO 10
  421.      PRINT FIELD_NAME$(B%+H%,I%);
  422.     NEXT
  423.     PRINT "   ";FIELD_TYPE$(B%+H%);"   ";
  424.     PRINT USING "###";ASC(LENGTH$(B%+H%));
  425.     PRINT "  ";
  426.     PRINT USING "##";ASC(DECI$(B%+H%));
  427.     PRINT "  ";
  428.     COLOR 0,7
  429.    END IF
  430.   NEXT
  431.   SELECT CASE PC%
  432.    CASE 1
  433.     FOR U%=1 TO 10
  434.      ASTR$(U%)=FIELD_NAME$(PL%+H%,U%)
  435.     NEXT
  436.     CALL FORM_INPUT(16,PL%+2,10)
  437.     FOR U%=1 TO 10
  438.      FIELD_NAME$(PL%+H%,U%)=UCASE$(ASTR$(U%))
  439.     NEXT
  440.    CASE 2
  441.     IF FIELD_TYPE$(PL%+H%)>CHR$(32) THEN
  442.      ASTR$(1)=FIELD_TYPE$(PL%+H%)
  443.     ELSE
  444.      ASTR$(1)=CHR$(32)
  445.     END IF
  446.     CALL FORM_INPUT(29,PL%+2,1)
  447.     IF ASTR$(1)=CHR$(32) THEN ASTR$(1)=CHR$(67)
  448.     FIELD_TYPE$(PL%+H%)=UCASE$(ASTR$(1))
  449.    CASE 3
  450.     IF LENGTH$(PL%+H%)> CHR$(0) THEN
  451.      ASTR$(1)=MID$(STR$(ASC(LENGTH$(PL%+H%))),2,1)
  452.      ASTR$(2)=MID$(STR$(ASC(LENGTH$(PL%+H%))),3,1)
  453.     ELSE
  454.      ASTR$(1)=CHR$(32)
  455.      ASTR$(2)=CHR$(32)
  456.     END IF
  457.     CALL FORM_INPUT(34,PL%+2,2)
  458.     LENGTH$(PL%+H%)=CHR$(VAL(ASTR$(1)+ASTR$(2)))
  459.    CASE 4
  460.     IF DECI$(PL%+H%)>CHR$(0) THEN
  461.      ASTR$(1)=MID$(STR$(ASC(DECI$(PL%+H%))),2,1)
  462.     ELSE
  463.      ASTR$(1)=CHR$(32)
  464.     END IF
  465.     CALL FORM_INPUT(39,PL%+2,1)
  466.     DECI$(PL%+H%)=CHR$(VAL(ASTR$(1)))
  467.   END SELECT
  468.   IF CH1$ = CHR$(117) THEN EXIT LOOP
  469.   IF CH1$ = CHR$(80) OR CH$ = CHR$(13) THEN
  470.     IF PC%<4 THEN
  471.      INCR PC%
  472.     ELSE
  473.      PC%=1
  474.      IF PL%<20 THEN
  475.       INCR PL%
  476.      ELSE
  477.       INCR H%
  478.      END IF
  479.     END IF
  480.   END IF
  481.   IF CH$ = CHR$(13) AND PL% + H% > K% THEN
  482.    IF LENGTH$(K%) > CHR$(0) AND K% < 100 THEN INCR K%
  483.    FOR D%=1 TO 11
  484.     FIELD_NAME$(PL%+H%,D%) = CHR$(32)
  485.    NEXT
  486.    FIELD_TYPE$(PL%+H%)=CHR$(32)
  487.    LENGTH$(PL%+H%)=CHR$(0)
  488.    DECI$(PL%+H%)=CHR$(0)
  489.   END IF
  490.   IF CH1$ = CHR$(75) THEN
  491.    IF PC% = 1 THEN
  492.     PC% = 4
  493.    ELSE
  494.     DECR PC%
  495.    END IF
  496.   END IF
  497.   IF CH1$ = CHR$(72) THEN
  498.    IF PL% > 1 THEN
  499.     DECR PL%
  500.    ELSE
  501.     DECR H%
  502.    END IF
  503.   END IF
  504.   IF PL% > K% THEN PL% = K%
  505.   IF H% < 0 THEN H% = 0
  506.   IF H% > K% - 20 AND PL% = 20 THEN H% = K% - 20
  507.  LOOP
  508.  IF LENGTH$(K%) = CHR$(0) THEN DECR K%
  509.  FOR I% = 1 TO K%
  510.   REG_LEN% = REG_LEN% + ASC(LENGTH$(I%))
  511.  NEXT
  512.  IF REG_LEN% > 0 THEN GOSUB INICIATE_IT
  513.  OPEN "B",#1,ARCH$
  514. RETURN
  515.  
  516. BROWSE_IT:
  517.  COLOR 7,0
  518.  POSI%=0
  519.  FOR H%=1 TO JP%
  520.   POSI%=POSI%+ASC(LENGTH$(H%))
  521.  NEXT
  522.  POREL%=POSI%
  523.  POLIM%=76
  524.  IF POREL%+POLIM%>REG_LEN% THEN POLIM%=REG_LEN%-POREL%
  525.  LIN$="รšร„ร„ร„ร„ร„ร„"
  526.  J%=JP%
  527.  PL%=7
  528.  R%=18
  529.  DO UNTIL J%=K% OR PL%>=79
  530.   INCR J%
  531.   PC%=0
  532.   LIN$=LIN$+CHR$(194)
  533.   INCR PL%
  534.   WHILE PC%<ASC(LENGTH$(J%)) AND PL%<79
  535.    INCR PC%
  536.    INCR PL%
  537.    LIN$=LIN$+CHR$(196)
  538.   WEND
  539.  LOOP
  540.  IF J%=K% THEN  'PRINT CHR$(191)+STRING$(79-PL%,32)
  541.  LIN$=LIN$+CHR$(191)+SPACE$(76)
  542.  END IF
  543.  LOCATE 1,1
  544.  COLOR 0,7
  545.  PRINT LEFT$(LIN$,79)
  546.  LIN$="ยณ Reg. "
  547.  J%=JP%
  548.  PL%=6
  549.  DO UNTIL J%=K% OR PL%>=79
  550.   INCR J%
  551.   PC%=0
  552.   LIN$=LIN$+CHR$(179)
  553.   INCR PL%
  554.   DO UNTIL FIELD_NAME$(J%,PC%)=CHR$(0) OR PC%=ASC(LENGTH$(J%)) OR PL%>=78
  555.    INCR PL%
  556.    INCR PC%
  557.    LIN$=LIN$+FIELD_NAME$(J%,PC%)
  558.   LOOP
  559.   WHILE PC%<ASC(LENGTH$(J%)) AND PL%<79
  560.    INCR PC%
  561.    INCR PL%
  562.    LIN$=LIN$+CHR$(32)
  563.   WEND
  564.  LOOP
  565.  IF J%=K% AND PL%<78 THEN LIN$=LIN$+CHR$(179)+SPACE$(76)
  566.  LOCATE 2,1
  567.  PRINT LEFT$(LIN$,79)
  568.  LIN$="รƒร„ร„ร„ร„ร„ร„"
  569.  PL%=7
  570.  J%=JP%
  571.  DO UNTIL J%=K% OR PL%>=79
  572.   INCR J%
  573.   PC%=0
  574.   LIN$=LIN$+CHR$(197)
  575.   INCR PL%
  576.   WHILE PC%<ASC(LENGTH$(J%)) AND PL%<79
  577.    INCR PC%
  578.    INCR PL%
  579.    LIN$=LIN$+CHR$(196)
  580.   WEND
  581.  LOOP
  582.  IF J%=K% THEN LIN$=LIN$+CHR$(180)+SPACE$(76)
  583.  LOCATE 3,1
  584.  PRINT LEFT$(LIN$,79)
  585.  IF R%>NOREG& THEN R%=NOREG&
  586.  FOR B%=1 TO R%
  587.   A&=(B%+N&-1)
  588.   IF A&<=NOREG& THEN GOSUB READ_IT
  589.   IF CONT(1)=CHR$(42) THEN
  590.    BG%=14
  591.   ELSE
  592.    BG%=7
  593.   END IF
  594.   IF B%=E& THEN
  595.    COLOR BG%,4
  596.   ELSE
  597.    COLOR 0,BG%
  598.   END IF
  599.   LIN$=CHR$(179)+USING$("######",A&)
  600.   I%=POREL%+1
  601.   J%=JP%
  602.   PL%=7
  603.   DO UNTIL J%=K% OR PL%>=79
  604.    INCR J%
  605.    FEC$=""
  606.    PC%=0
  607.    LIN$=LIN$+CHR$(179)
  608.    INCR PL%
  609.    DO UNTIL PC%=ASC(LENGTH$(J%)) OR PL%>=79
  610.     INCR I%
  611.     INCR PC%
  612.     IF FIELD_TYPE$(J%)=CHR$(68) THEN
  613.      FEC$=FEC$+CONT(I%)
  614.     ELSE
  615.      LIN$=LIN$+CONT(I%)
  616.      INCR PL%
  617.     END IF
  618.    LOOP
  619.    IF FIELD_TYPE$(J%)=CHR$(68) THEN LIN$=LIN$+MID$(FEC$,7,2)+"/"+MID$(FEC$,5,2)+"/"+MID$(FEC$,3,2)
  620.   LOOP
  621.   IF J%=K% THEN LIN$=LIN$+CHR$(179)+SPACE$(76)
  622.   LOCATE B%+3
  623.   PRINT LEFT$(LIN$,79)
  624.  NEXT
  625.  COLOR 0,7
  626.  LIN$="ร€ร„ร„ร„ร„ร„ร„"
  627.  J%=JP%
  628.  PL%=7
  629.  DO UNTIL J%=K% OR PL%>=79
  630.   INCR J%
  631.   PC%=0
  632.   LIN$=LIN$+CHR$(193)
  633.   INCR PL%
  634.   WHILE PC%<ASC(LENGTH$(J%)) AND PL%<79
  635.    INCR PC%
  636.    INCR PL%
  637.    LIN$=LIN$+CHR$(196)
  638.   WEND
  639.  LOOP
  640.  IF J%=K% THEN LIN$=LIN$+CHR$(217)+SPACE$(76)
  641.  LOCATE B%+3,1
  642.  PRINT LEFT$(LIN$,79)
  643.  GOSUB STATUS_BAR
  644. RETURN
  645.  
  646. ADD_IT:
  647.  SEEK #1,HEAD_LEN%+NOREG&*REG_LEN%
  648.  PUT$ #1,STRING$(REG_LEN%,32)+CHR$(26)
  649.  INCR NOREG&
  650.  SEEK #1,4
  651.  PUT$ #1,MKL$(NOREG&)
  652.  N&=NOREG&
  653.  E&=1
  654. RETURN
  655.  
  656. EDIT_IT:
  657.  POREL%=0
  658.  POLIM%=REG_LEN%
  659.  A&=(N&+E&-1)
  660.  GOSUB READ_IT
  661.  H%=0
  662.  POSI%=2
  663.  PL%=1
  664.  R%=0
  665.  DO
  666.   FOR B%=1 TO 22
  667.    LOCATE B%,1:PRINT SPC(79);
  668.    IF (B%+H%>0) AND (B%+H%<=K%) THEN
  669.     LOCATE B%,1
  670.     FEC$=""
  671.     PRINT USING "###";B%+H%;
  672.     PRINT " ";
  673.     FOR I%=1 TO 10
  674.      PRINT FIELD_NAME$(B%+H%,I%);
  675.     NEXT
  676.     PRINT " ";FIELD_TYPE$(B%+H%);
  677.     PRINT USING "###";ASC(LENGTH$(B%+H%));
  678.     PRINT USING "##";ASC(DECI$(B%+H%));
  679.     PRINT " ";
  680.     'IF PL%=B% THEN COLOR 7,0
  681.    FOR I%=POSI% TO POSI%+ASC(LENGTH$(B%+H%))-1
  682.      IF FIELD_TYPE$(B%+H%)=CHR$(68) THEN
  683.       FEC$=FEC$+CONT(I%)
  684.      ELSE
  685.       PRINT CONT(I%);
  686.      END IF
  687.     NEXT
  688.     IF FIELD_TYPE$(B%+H%)=CHR$(68) THEN PRINT MID$(FEC$,7,2)+"/"+MID$(FEC$,5,2)+"/"+MID$(FEC$,3,2);
  689.     POSI%=POSI%+ASC(LENGTH$(B%+H%))
  690.     COLOR 0,7
  691.    ELSE
  692.    END IF
  693.   NEXT
  694.   GOSUB STATUS_BAR
  695.   PR%=2
  696.   FOR U%=1 TO PL%+H%-1
  697.    PR%=PR%+ASC(LENGTH$(U%))
  698.   NEXT
  699.   PE%=PR%+ASC(LENGTH$(PL%+H%))
  700.   D%=0
  701.   FOR U%=PR% TO PE%
  702.    INCR D%
  703.    ASTR$(D%)=CONT(U%)
  704.   NEXT
  705.   CALL FORM_INPUT(23,PL%,ASC(LENGTH$(PL%+H%)))
  706.   IF FIELD_TYPE$(PL%+H%)=CHR$(78) THEN
  707.    D%=PE%-PR%
  708.    FOR U%=PE%-PR% TO 1 STEP -1
  709.     IF CH1$=CHR$(83) THEN CONT(PR%+U%-1)=CHR$(32)
  710.     IF ASTR$(U%)<>CHR$(32) THEN
  711.      DECR D%
  712.      CONT(PR%+D%)=ASTR$(U%)
  713.     END IF
  714.    NEXT
  715.   ELSE
  716.    D%=0
  717.    FOR U%=PR% TO PE% - 1
  718.     INCR D%
  719.     CONT(U%)=ASTR$(D%)
  720.    NEXT
  721.   END IF
  722.   IF CH$=CHR$(13) OR CH$=CHR$(0,83) THEN
  723.    A&=N&+E&-1
  724.    GOSUB WRITE_IT
  725.    IF H%+PL%=K% THEN EXIT LOOP
  726.   END IF
  727.   IF CH$=CHR$(0,80) OR CH$=CHR$(13) THEN
  728.    IF PL%<22 THEN
  729.     INCR PL%
  730.    ELSE
  731.     INCR H%
  732.    END IF
  733.   END IF
  734.   IF CH$=CHR$(0,72) THEN
  735.    IF PL%>1 THEN
  736.     DECR PL%
  737.    ELSE
  738.     DECR H%
  739.    END IF
  740.   END IF
  741.   IF CH$=CHR$(0,81) THEN
  742.    IF E&<MIN(NOREG&,19) THEN
  743.     INCR E&
  744.    ELSE
  745.     INCR N&
  746.    END IF
  747.    IF N&>NOREG&-19 THEN N&=NOREG&-19
  748.    A&=N&+E&-1
  749.    GOSUB READ_IT
  750.   END IF
  751.   IF CH$=CHR$(0,73) THEN
  752.    IF E&>1 THEN
  753.     DECR E&
  754.    ELSE
  755.     DECR N&
  756.    END IF
  757.    IF N&<1 THEN N&=1
  758.    A&=N&+E&-1
  759.    GOSUB READ_IT
  760.   END IF
  761.   IF PL%>K% THEN
  762.    PL%=1
  763.    CH$=CHR$(0,117)
  764.   END IF
  765.   IF H%<0 THEN H%=0
  766.   IF H%>K%-22 AND PL%=22 THEN H%=K%-22
  767.   POSI%=2
  768.   FOR B%=1 TO H%
  769.    POSI%=POSI%+ASC(LENGTH$(B%))
  770.   NEXT
  771.   IF CH$=CHR$(0,117) OR CH$=CHR$(27) THEN EXIT
  772.  LOOP
  773. RETURN
  774.  
  775. SUB MENUTASK(YS%,XS%,AM%,NO%,MTR$(),OP%)
  776.  IP%=1
  777.  OP%=0
  778.  CALL WIN(YS%,XS%,AM%+1,MIN(NO%,12),1)
  779.  L$=""
  780.  COLOR 1,7
  781.  LOCATE 23,2:PRINT SPC(78)
  782.  DO
  783.   COLOR 15,11
  784.   FOR G%=1 TO MIN(NO%,12)
  785.    LOCATE YS%+G%,XS%+1:PRINT CHR$(32);
  786.    IF IP%=G%  THEN
  787.     COLOR 4,15
  788.    ELSE
  789.     COLOR 15,11
  790.    END IF
  791.    PRINT CHR$(32)+LEFT$(MTR$(G%+OP%)+STRING$(AM%,32),AM%);
  792.    COLOR 15,11
  793.    PRINT CHR$(32);
  794.   NEXT
  795.   DO UNTIL INSTAT
  796.   LOOP
  797.   O$=INKEY$
  798.   SELECT CASE O$
  799.    CASE CHR$(27)
  800.     OP%=0
  801.     EXIT LOOP
  802.    CASE CHR$(0,80)
  803.     IF IP%<MIN(NO%,12) THEN
  804.      INCR IP%
  805.     ELSE
  806.      IF OP%<NO%-MIN(NO%,12) THEN INCR OP%
  807.     END IF
  808.    CASE CHR$(0,72)
  809.     IF IP%>1 THEN
  810.      DECR IP%
  811.     ELSE
  812.      IF OP%>0 THEN DECR OP%
  813.     END IF
  814.    CASE CHR$(0,81)
  815.     OP%=OP%+MIN(NO%,12)
  816.     IP%=MIN(NO%,12)
  817.    CASE CHR$(0,73)
  818.     OP%=OP%-MIN(NO%,12)
  819.     IF OP%<0 THEN OP%=0
  820.     IP%=1
  821.    CASE CHR$(0,79)
  822.     OP%=NO%-MIN(NO%,12)
  823.     IP%=MIN(NO%,12)
  824.    CASE CHR$(0,71)
  825.     IP%=1
  826.     OP%=0
  827.    CASE CHR$(13)
  828.     OP%=IP%+OP%
  829.     EXIT LOOP
  830.   END SELECT
  831.   IF OP%>NO%-MIN(NO%,12) THEN OP%=NO%-MIN(NO%,12)
  832.   IF IP%<1 THEN
  833.    IP%=1
  834.    IF OP%>NO%-1 THEN OP%=NO%-1
  835.   END IF
  836.  LOOP
  837.  CALL WIN(YS%,XS%,AM%+1,MIN(NO%,12),0)
  838. END SUB
  839.  
  840. SUB WIN(YS%,XS%,AM%,NO%,P%)
  841.  SHARED L$()
  842.  IF P%=1 THEN
  843.   FOR F%=YS% TO YS%+NO%+2
  844.    L$=""
  845.    FOR V%=XS%-1 TO XS%+AM%+3
  846.    L$=L$+CHR$(SCREEN(F%,V%))
  847.    NEXT
  848.    L$(F%)=L$
  849.   NEXT
  850.   COLOR 15,11
  851.   LOCATE YS%,XS%:PRINT CHR$(218);STRING$(AM%+2,196);CHR$(191);
  852.   LOCATE YS%+NO%+1,XS%:PRINT CHR$(192);STRING$(AM%+2,196);CHR$(217);
  853.   FOR G%=1 TO NO%
  854.    LOCATE YS%+G%,XS%:PRINT CHR$(179)+STRING$(AM%+2,32)+CHR$(179);
  855.   NEXT
  856.  ELSE
  857.   COLOR 0,7
  858.   FOR V%=YS% TO YS%+NO%+2
  859.    LOCATE V%,XS%-1
  860.    PRINT L$(V%);
  861.   NEXT
  862.  END IF
  863. END SUB
  864.  
  865. PACK:
  866.  CLOSE 1
  867.  OPEN "TMPDBF.BIN" FOR BINARY SHARED AS #1
  868.  CLOSE 1
  869.  KILL "TMPDBF.BIN"
  870.  P&=0
  871.  NAME ARCH$ AS "TMPDBF.BIN"
  872.  OPEN "TMPDBF.BIN" FOR BINARY SHARED AS #1
  873.  IF LOF(1)>0 THEN
  874.   OPEN ARCH$ FOR BINARY SHARED AS #2
  875.   GET$ #1,HEAD_LEN%,L$
  876.   PUT$ #2,L$
  877.   FOR A&=1 TO NOREG&
  878.    SEEK #1,HEAD_LEN%+(A&-1)*REG_LEN%
  879.    GET$ #1,REG_LEN%,L$
  880.    IF LEFT$(L$,1)<>CHR$(42) THEN
  881.     INCR P&
  882.     PUT$ #2,L$
  883.    END IF
  884.   NEXT
  885.   NOREG&=P&
  886.   SETEOF #2
  887.   SEEK #2,4
  888.   PUT$ #2,MKL$(NOREG&)
  889.   CLOSE 1
  890.   CLOSE 2
  891.  END IF
  892.  OPEN ARCH$ FOR BINARY SHARED AS #1
  893. RETURN
  894.  
  895. DELETE_RECORD:
  896.  A&=N&+E&-1
  897.  SEEK #1,HEAD_LEN%+(A&-1)*REG_LEN%
  898.  GET$ #1,1,L$
  899.  IF L$<>CHR$(42) THEN
  900.   L$=CHR$(42)
  901.  ELSEIF L$=CHR$(42) THEN
  902.   L$=CHR$(32)
  903.  END IF
  904.  SEEK #1,HEAD_LEN%+(A&-1)*REG_LEN%
  905.  PUT$ #1,L$
  906. RETURN
  907.  
  908. INDEX:
  909.  CALL MENUTASK(2,2,11,K%,FLN$(),OP%)
  910.  IF OP%>0 THEN
  911.   RELPOS%=1
  912.   FOR J&=1 TO OP%-1
  913.    RELPOS%=RELPOS%+ASC(LENGTH$(J&))
  914.   NEXT
  915.   OFS%=HEAD_LEN%+RELPOS%
  916.   LR%=ASC(LENGTH$(OP%))
  917.   FLG%=0
  918.   CLOSE 3
  919.   OPEN LEFT$(REMOVE$(ARCH$,".DBF"),5)+RIGHT$(USING$("####",1000+OP%),3)+".NDX" FOR BINARY AS #3
  920.   IF LOF(3)<>4*NOREG& THEN
  921.    FOR I&=1 TO NOREG&
  922.     PUT$ #3,MKL$(I&)
  923.    NEXT
  924.    SETEOF 3
  925.    CALL QSortExp(1,NOREG&)
  926.   END IF
  927.   FLG%=1
  928.  END IF
  929. RETURN
  930.  
  931. SUB QSortExp(Head&,Tail&)
  932.  H&=Head&
  933.  T&=Tail&
  934.  P$=Pivot$((Head&+Tail&)\2)
  935.  DO
  936.   DO WHILE Pivot$(H&)<P$ AND H&<Tail&
  937.    INCR H&
  938.   LOOP
  939.   DO WHILE Pivot$(T&)>P$ AND T&>Head&
  940.    DECR T&
  941.   LOOP
  942.   IF H&<=T& THEN
  943.    CALL SWAPITEMS(H&,T&)
  944.    INCR H&
  945.    DECR T&
  946.   END IF
  947.  LOOP WHILE H&<=T&
  948.  IF Head& < T& THEN
  949.   CALL QSortExp(Head&,T&)
  950.  END IF
  951.  IF H& < Tail& THEN
  952.   CALL QSortExp(H&, Tail&)
  953.  END IF
  954. END SUB
  955.  
  956. FUNCTION Pivot$(RecNum&)
  957.  SHARED REG_LEN%,OFS%,LR%
  958.  GET #3,4*(RecNum&-1),RN&
  959.  SEEK #1,OFS%+(RN&-1)*REG_LEN%
  960.  GET$ #1,LR%,I$
  961.  Pivot$=I$
  962. END FUNCTION
  963.  
  964.  SUB SWAPITEMS(I&,J&)
  965.  GET #3,4*(I&-1),C&
  966.  GET #3,4*(J&-1),D&
  967.  PUT #3,4*(I&-1),D&
  968.  PUT #3,4*(J&-1),C&
  969. END SUB
  970.  
  971. HELP:
  972.  CALL WIN(4,4,60,19,1)
  973.  LOCATE 6,7:PRINT "F2 - Indexes on a field content"
  974.  LOCATE 8,7:PRINT "F3 - Reverses order"
  975.  LOCATE 10,7:PRINT "F4 - Deletes the current record. (Marks it to be erased)"
  976.  LOCATE 12,7:PRINT "F5 - Pack. Erases marked records"
  977.  LOCATE 14,7:PRINT "E  - Switch to the Edit Mode"
  978.  LOCATE 16,7:PRINT "A  - Switch to the Append Mode"
  979.  LOCATE 18,7:PRINT "S  - Search on a selected field, or on the whole records"
  980.  LOCATE 20,7:PRINT "R  - Continue Searching"
  981.  LOCATE 22,7:PRINT "G  - Goes to Record Number"
  982.  DO UNTIL INSTAT
  983.  LOOP
  984.  O$=INKEY$
  985.  CALL WIN(4,4,60,19,0)
  986. RETURN
  987.  
« Last Edit: August 30, 2015, 03:35:18 AM by John »

Offline AIR

  • BASIC Developer
  • Posts: 932
  • Coder
Re: Record based file indexing
« Reply #1 on: August 30, 2015, 07:05:37 PM »
Would be helpful to see a screenshot, to see if it's worth doing... ;D

Offline John

  • Forum Support / SB Dev
  • Posts: 3510
    • ScriptBasic Open Source Project
Re: Record based file indexing
« Reply #2 on: August 30, 2015, 07:57:41 PM »
I agree!

Here is all I can provide at the moment.

PowerBASIC Forum Post

Thanks AIR for your interest and post.

Maybe you can give us an example of your OSX GUI you have been working on using this code in any BASIC you chose.

FYI Script BASIC has all the record support built into the language and I would to love see SB working with your GUI library.

« Last Edit: August 30, 2015, 08:15:59 PM by John »

Offline John

  • Forum Support / SB Dev
  • Posts: 3510
    • ScriptBasic Open Source Project
Re: Record based file indexing
« Reply #3 on: September 13, 2015, 11:37:38 PM »
I notice this DBF (DBase) file definition on the PowerBASIC forum post by Brian Alvarez. Thanks!

xbase data file structure