home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / FILER.ZIP / DATTOPIC.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1985-11-18  |  8.1 KB  |  244 lines
  1. (***************************************************************)
  2. (*                                                             *)
  3. (*        FILER A LA PASCAL DATA BASE SOURCE CODE FILE         *)
  4. (*                                                             *)
  5. (*        (C) 1985 by  John M. Harlan                          *)
  6. (*                     24000 Telegraph                         *)
  7. (*                     Southfield, MI. 48034                   *)
  8. (*                                                             *)
  9. (*     The FILER GROUP of programs is released on a "FREE      *)
  10. (*     SOFTWARE" basis.  The recipient is free to examine      *)
  11. (*     and use the software with the understanding that if     *)
  12. (*     the FILER GROUP of programs prove to be of use and      *)
  13. (*     value,  a contribution to the author is encouraged.     *)
  14. (*                                                             *)
  15. (*     While reasonable effort has been made to ensure the     *)
  16. (*     reliability of the FILER GROUP of programs, no war-     *)
  17. (*     ranty is given. The recipient uses the programs at      *)
  18. (*     his own risk  and in no event shall the author be       *)
  19. (*     liable for damages arising from their use.              *)
  20. (*                                                             *)
  21. (*                                                             *)
  22. (***************************************************************)
  23.  
  24.  
  25. PROGRAM DATTOPIC;  { ONE OF THE FILER GROUP OF PROGRAMS }
  26. { CONVERTS A FILER DAT FILE TO A PIC FILE }
  27. { DATTOPIC.PAS  VERSION 2.0 }
  28. { MAY 20, 1985 }
  29.  
  30.  
  31. TYPE
  32.   RANGE          = ARRAY[1..256] OF CHAR;
  33.   STRING79       = STRING[79];
  34.   NAMESTR        = STRING[12];
  35. VAR
  36.  
  37.   CH,OPTION      : CHAR;
  38.  
  39.   FILENME        : STRING[6];
  40.   FILEDATE       : STRING[8];
  41.   FILENAME       : STRING[12];
  42.   ANS            : STRING79;
  43.   MESS           : STRING79;
  44.  
  45.   V,W,X,Z,
  46.   MAXNBRREC, NBRRECUSED, RCDLEN,
  47.   BLOCKINGFACTOR, FIELDPERRECORD,
  48.   ASCII, DECPTR                              :    INTEGER;
  49.  
  50.   FILEEXISTS                                 :    BOOLEAN;
  51.  
  52.  
  53.   LABELLENGTH, DATALEN, DATAFORM,
  54.   LABELPOSN, DATAPOSN, ROW,
  55.   COLUMN, FIELDNBR                  :    ARRAY[1..32] OF INTEGER;
  56.   LBL                               :    ARRAY[1..384] OF CHAR;
  57.   LINE                              :    ARRAY[1..30] OF STRING79;
  58.   GETDATA                           :    RANGE;
  59.  
  60.   SOURCE                            :    FILE;
  61.   DATTOPIC                          :    TEXT;
  62.  
  63. {================================================================}
  64. {        BINARY CODED DECIMAL TO INTEGER FUNCTION                }
  65. {================================================================}
  66. FUNCTION BCDTOIN (CHA : CHAR) : INTEGER;
  67. BEGIN
  68.   BCDTOIN := ORD(CHA) - TRUNC(ORD(CHA)/16)*6;
  69. END;
  70. {================================================================}
  71. {             CHARACTER TO INTEGER FUNCTION                      }
  72. {================================================================}
  73. FUNCTION CHTOIN(VAR CHARRAY : RANGE; START, LEN : INTEGER)  : INTEGER;
  74. VAR
  75.   CODE, RESULT : INTEGER;
  76.   WORKSTRING   : STRING[10];
  77. BEGIN
  78.   WORKSTRING := '';
  79.   FOR RESULT := 0 TO LEN-1  DO
  80.     BEGIN
  81.       IF CHARRAY[START + RESULT ] = ' ' THEN
  82.         WORKSTRING := WORKSTRING + '0'
  83.       ELSE WORKSTRING := WORKSTRING + CHARRAY[START+RESULT];
  84.     END;
  85.   VAL(WORKSTRING,RESULT,CODE);
  86.   CHTOIN := RESULT;
  87. END;
  88. {===============================================================}
  89. {                       FUNCTION EXIST                          }
  90. {===============================================================}
  91. FUNCTION EXIST(FILENAME : NAMESTR) : BOOLEAN;
  92. VAR
  93.   FIL :  FILE;
  94. BEGIN
  95.   ASSIGN(FIL,FILENAME);
  96.   {$I-}
  97.   RESET(FIL);
  98.   {$I+}
  99.   EXIST := (IORESULT = 0)
  100. END;
  101.  
  102. {################################################################}
  103. {                                                                }
  104. {                         MAIN PROGRAM                           }
  105. {                         ============                           }
  106. {################################################################}
  107.  
  108.  
  109. BEGIN
  110.   REPEAT
  111.     CLRSCR;
  112.     GOTOXY(1,24);
  113.     WRITELN('"DATTOPIC" CONVERTS FILES FROM XXX.DAT TO XXX.PIC');
  114.     WRITELN;
  115.     WRITE('ENTER FILENAME OF PICTURE FILE : ');
  116.     READLN(FILENAME);
  117.     X := POS('.',FILENAME);
  118.     IF X <> 0 THEN FILENAME := COPY(FILENAME,1,X-1);
  119.     FILENAME := FILENAME + '.DAT';
  120.     WRITELN(FILENAME);
  121.     FILEEXISTS := EXIST(FILENAME);
  122.   UNTIL FILEEXISTS = TRUE;
  123.   ASSIGN( SOURCE, FILENAME );
  124.   RESET( SOURCE );
  125.   SEEK(SOURCE,1);
  126.   BLOCKREAD( SOURCE,GETDATA,1 );
  127.   BLOCKREAD( SOURCE,LBL,3 );
  128.   FILENME := 'XXXXXX';
  129.   FOR X := 1 TO 6 DO
  130.     FILENME[X] := GETDATA[X];
  131.   MAXNBRREC := CHTOIN(GETDATA,7,4);
  132.   NBRRECUSED := CHTOIN(GETDATA,11,4);
  133.   RCDLEN := CHTOIN(GETDATA,15,3);
  134.   BLOCKINGFACTOR := CHTOIN(GETDATA,18,2);
  135.   FIELDPERRECORD := CHTOIN(GETDATA,20,2);
  136.  
  137.   FILEDATE := '        ';
  138.   MOVE(GETDATA[22],FILEDATE[1],8);
  139.  
  140. {================================================================}
  141. {  GET LABEL LENGTH, DATA LENGTH & DATA FORM INFO                }
  142. {================================================================}
  143.  
  144. LABELPOSN[1] := 1;
  145. DATAPOSN[1] := 1;
  146.  
  147. FOR X := 1 TO FIELDPERRECORD DO
  148.   BEGIN
  149.     LABELLENGTH[X] :=  BCDTOIN(GETDATA[32+X]);
  150.     DATALEN[X]     :=  BCDTOIN(GETDATA[64+X]);
  151.     DATAFORM[X]    :=  ORD(GETDATA[96+X])-48;
  152.     LABELPOSN[X+1] :=  LABELPOSN[X] + LABELLENGTH[X];
  153.     DATAPOSN[X+1]  :=  DATAPOSN[X] + DATALEN[X];
  154.   END;
  155.  
  156. {================================================================}
  157. {           TRANSLATE REPORT STRUCTURE                           }
  158. {================================================================}
  159.  
  160.   BLOCKREAD(SOURCE,GETDATA,1);  { SCREEN INFORMATION }
  161.       { ESTABLISH VALUE OF DATAFORM[Z] FOR ASCII INFORMATION }
  162.       IF GETDATA[1] = 'S' THEN ASCII := 9 ELSE ASCII := 15;
  163.   FOR X := 1 TO FIELDPERRECORD DO
  164.     BEGIN
  165.       W := X*4+1;
  166.       ROW[X]       := BCDTOIN(GETDATA[W]);
  167.       COLUMN[X] := BCDTOIN(GETDATA[W+1])*10+TRUNC(BCDTOIN(GETDATA[W+2])/10);
  168.       {FIELDNBR[X]  := BCDTOIN(GETDATA[W+3]);} { NOT IMPLEMENTED }
  169.     END;
  170.  
  171. {================================================================}
  172. {                 BUILD PICTURE IN LINE ARRAY                    }
  173. {================================================================}
  174.  
  175.   FOR Z := 1 TO 30 DO
  176.     BEGIN
  177.       FOR X := 0 TO 79 DO
  178.         LINE[Z][X] := ' ';
  179.       LINE[Z][0] := CHR(79);
  180.     END;
  181.   FOR Z := 1 TO FIELDPERRECORD DO
  182.     BEGIN
  183.       V := COLUMN[Z];
  184.       FOR X := LABELPOSN[Z] TO LABELPOSN[Z+1]-1 DO
  185.         BEGIN
  186.           LINE[ROW[Z]][V] := LBL[X];
  187.           V := V+1;
  188.         END;
  189.       LINE[ROW[Z]][V+1] := ':';
  190.       V := V +3;
  191.  
  192.       MESS := '';
  193.       IF DATAFORM[Z] = ASCII THEN
  194.         BEGIN
  195.           FOR X := 1 TO DATALEN[Z] DO
  196.             MESS := MESS + 'A';
  197.         END
  198.       ELSE
  199.         BEGIN
  200.           MESS := '';
  201.           FOR X := 1 TO DATALEN[Z]-1 DO
  202.             MESS := MESS + '_';
  203.           IF DATAFORM[Z] = 0 THEN
  204.             MESS := MESS + '_'
  205.           ELSE
  206.             INSERT('.',MESS,(LENGTH(MESS)-DATAFORM[Z]+1));
  207.           IF DATAFORM[Z] = 0 THEN DECPTR := DATALEN[Z]-2
  208.           ELSE
  209.             DECPTR := DATALEN[Z] - DATAFORM[Z] - 3;
  210.           WHILE DECPTR >1 DO
  211.             BEGIN
  212.               INSERT(',',MESS,DECPTR);
  213.               DECPTR := DECPTR -3;
  214.             END;
  215.         END;
  216.  
  217.       FOR W := 1 TO LENGTH(MESS) DO
  218.         BEGIN
  219.           LINE[ROW[Z]][V] := MESS[W];
  220.           V := V+1;
  221.         END;
  222.       LINE[ROW[Z]] := COPY(LINE[ROW[Z]],1,79);
  223.       CLOSE(SOURCE)
  224.     END;
  225.   CLRSCR;
  226.   FOR X := 1 TO 22 DO
  227.     BEGIN
  228.       LINE[X] := COPY(LINE[X],1,79);
  229.       WRITELN(LINE[X]);
  230.     END;
  231.   X := POS('.',FILENAME);
  232.   IF X <> 0 THEN FILENAME := COPY(FILENAME,1,X-1);
  233.   FILENAME := FILENAME + '.PIC';
  234.   ASSIGN (DATTOPIC,FILENAME);
  235.   REWRITE(DATTOPIC);
  236.   FOR X := 1 TO 24 DO
  237.     BEGIN
  238.       LINE[X] := COPY(LINE[X],1,79);
  239.       WRITELN(DATTOPIC,LINE[X]);
  240.     END;
  241.   CLOSE(DATTOPIC);
  242.   GOTOXY(1,24);
  243.   WRITELN(FILENAME,' CREATED');
  244. END.