home *** CD-ROM | disk | FTP | other *** search
/ Der Mediaplex Sampler - Die 6 von Plex / 6_v_plex.zip / 6_v_plex / DISK5 / DOS_18 / DATEX3.ZIP / UNIDAT.PAS < prev    next >
Pascal/Delphi Source File  |  1993-05-11  |  17KB  |  627 lines
  1. unit unidat;
  2.  
  3. (********************************************************************)
  4. (*                   Unit UniDat von A.Mehling                      *)
  5. (*                   Version vom 10.04.1993                         *)
  6. (********************************************************************)
  7.  
  8. interface
  9. uses dos;
  10.  
  11. type  UType        = (UShortInt,UByte,UWord,UInteger,ULongint,
  12.                       UReal,USingle,UDouble,UExtended,UComp);
  13.  
  14.       CType        = (USI,UBY,UWO,UIN,ULO,UC,UG,US);
  15.  
  16.       UniFile = record
  17.                 Uf : file;
  18.                 end;
  19.       UniInfo = record
  20.                 Max  : word;
  21.                 XPack: CType;
  22.                 YPack: CType;
  23.                 Info : string;
  24.                 end;
  25.  
  26. const UniComp      : boolean = false;
  27.  
  28.       UniOK        = 0;
  29.       UniError     = -1;
  30.       NoUniFile    = -2;
  31.       NoUniMem     = -3;
  32.       NoUniAss     = -4;
  33.       UniInvRec    = -5;
  34.       NoUniExist   = -6;
  35.       UniTooSmall  = -7;
  36.  
  37.       UniResult    : integer = UniError;
  38.  
  39.  
  40. Procedure UniAssign  (var Ufr:UniFile; Name:pathstr);
  41. Function  UniGetMax  (var Ufr:UniFile):word;
  42. Procedure UniGetInfo (var Ufr:UniFile; var Inf:UniInfo; Nr:word);
  43. Procedure UniReWrite (var Ufr:UniFile; xp,yp:Pointer;
  44.                       TMax:word; UID:string; T:UType);
  45. Procedure UniAppend  (var Ufr:UniFile; xp,yp:Pointer;
  46.                       TMax:word; UID:string; T:UType);
  47. Procedure UniRead    (var Ufr:UniFile; var xp,yp:Pointer; Nr:word;
  48.                       var TMax:word; T:UType);
  49.  
  50. implementation
  51.  
  52. Type    PRec   = record
  53.                  O,S : word;
  54.                  end;
  55.  
  56.         UFMask = record
  57.                  Handle   : word;
  58.                  Mode     : word;
  59.                  RecSize  : word;
  60.                  Private  : array[1..26] of byte;
  61.                  UserData : array[1..10] of byte;
  62.                  Exist    : boolean;
  63.                  AssErr   : integer;
  64.                  MaxK     : word;
  65.                  NamStr   : string[80];
  66.                  end;
  67.  
  68.    TUniDatHead = record
  69.                  HSize   : word;
  70.                  HIdent  : string[4];
  71.                  Max     : word;
  72.                  HWModeX : CType;
  73.                  HWModeY : CType;
  74.                  X0,XS   : extended;
  75.                  Y0,YS   : extended;
  76.                  HInfo   : string;
  77.                  end;
  78.  
  79. const TSUShortint = SizeOf(ShortInt);
  80.       TSUByte     = SizeOf(Byte);
  81.       TSUWord     = SizeOf(Word);
  82.       TSUInteger  = SizeOf(Integer);
  83.       TSULongint  = SizeOf(Longint);
  84.       TSUReal     = SizeOf(Real);
  85.       TSUSingle   = SizeOf(Single);
  86.       TSUDouble   = SizeOf(Double);
  87.       TSUExtended = SizeOf(Extended);
  88.       TSUComp     = SizeOf(Comp);
  89.  
  90.       TCS : array[CType] of Byte = (1,1,2,2,4,2,0,4);
  91.  
  92.       TInt : set of UType = [UShortInt,UByte,UWord,UInteger,ULongint];
  93.       TSin : set of UType = [UReal,USingle,UDouble,UExtended,UComp];
  94.  
  95.       UIdent   = 'UniD';
  96.       Toll     = 1e-4;
  97.       MaxWord  = $FFFF;
  98.       MaxHSize = SizeOf(TUniDatHead);
  99.  
  100. var  NewOne : boolean;
  101.      sAR    : single;
  102.      iAR    : array[1..2] of integer absolute sAR;
  103.      bAR    : array[1..4] of byte    absolute sAR;
  104.  
  105. Function TS(T:UType):byte;
  106. begin
  107.    case T of
  108.    UShortint : TS := SizeOf(ShortInt);
  109.    UByte     : TS := SizeOf(Byte);
  110.    UWord     : TS := SizeOf(Word);
  111.    UInteger  : TS := SizeOf(Integer);
  112.    ULongint  : TS := SizeOf(Longint);
  113.    UReal     : TS := SizeOf(Real);
  114.    USingle   : TS := SizeOf(Single);
  115.    UDouble   : TS := SizeOf(Double);
  116.    UExtended : TS := SizeOf(Extended);
  117.    UComp     : TS := SizeOf(Comp);
  118.    end;
  119. end;
  120.  
  121.  
  122. Procedure Make_HSize(var Head:TUniDatHead);
  123. begin
  124.    with Head do
  125.    begin
  126.    HIdent  := UIdent;
  127.    HSize   := (SizeOf(TUniDatHead)-$FF+Length(HInfo));
  128.    end;
  129. end;
  130.  
  131. function exist(name:pathstr):boolean;
  132. var probe:file;
  133.     w:word;
  134. begin
  135.   assign(probe,name);
  136.   getfattr(probe,w);
  137.   if doserror=0 then exist:=true else exist:=false;
  138.   if w=$10 then exist:=false;
  139. end;
  140.  
  141. Procedure ReadHead(var Ufr:UniFile; var Head:TUniDatHead);
  142. var   i      : longint;
  143.       Rest   : longint;
  144.       Result : word;
  145. const S    = SizeOf(word);
  146. begin
  147. With Ufr do
  148. begin
  149. UniResult:=NoUniFile;
  150.    with Head do
  151.    begin
  152.    BlockRead(Uf,HSize,S,result);
  153.    if Result<S       then exit;
  154.    if HSize>MaxHSize then exit;
  155.    if HSize<S        then exit;
  156.    BlockRead(Uf,HIdent,HSize-S,result);
  157.    if Result<(HSize-S) then exit;
  158.    if HIdent<>UIdent then exit;
  159.    end;
  160. UniResult:=UniOK;
  161. end;
  162. end;
  163.  
  164. Procedure WriteHead(var Ufr:UniFile; var Head:TUniDatHead);
  165. var Result:word;
  166. begin
  167. With Ufr do
  168. begin
  169. UniResult:=UniError;
  170. BlockWrite(Uf,Head,Head.HSize,Result);
  171. if Result<Head.HSize then exit;
  172. UNiResult:=UniOK;
  173. end;
  174. end;
  175.  
  176. Function DSize(Head:TUniDatHead):longint;
  177. var xsize,ysize : word;
  178. begin
  179. DSize:=0;
  180.    with Head do
  181.    begin
  182.    xsize:=TCS[HWModeX]*Max;
  183.    ysize:=TCS[HWModeY]*Max;
  184.    end;
  185. DSize:=xsize+ysize;
  186. end;
  187.  
  188. Function UniGetMax;
  189. var MUf : UfMask absolute Ufr;
  190. begin
  191. UniGetMax:=MUf.MaxK;
  192. end;
  193.  
  194. Procedure UniAssign;
  195. var Head : TUniDatHead;
  196.     MUf  : UfMask absolute Ufr;
  197.     Stop : boolean;
  198. begin
  199. With Ufr do
  200. begin
  201. UniResult:=UniOK;
  202. assign(Uf,Name);
  203. MUf.MaxK  := 0;
  204. MUf.Exist := exist(Name);
  205. Stop:=false;
  206.    if MUf.Exist then
  207.    begin
  208.    reset(Uf,1);
  209.       repeat
  210.       ReadHead(Ufr,Head);
  211.       MUf.AssErr:=UniResult;
  212.       if UniResult<0 then Stop:=true;
  213.          if not Stop then
  214.          begin
  215.          inc(MUf.MaxK);
  216.          seek(Uf,FilePos(Uf)+DSize(Head));
  217.          end
  218.          else MUf.AssErr:=UniResult;
  219.       until eof(UF) or Stop;
  220.    close(Uf);
  221.    end
  222.    else
  223.    begin
  224.    UniResult:=NoUniExist;
  225.    MUf.AssErr := UniOK;
  226.    end;
  227. end;
  228. end;
  229.  
  230. Procedure UniGetInfo;
  231. var Head : TUniDatHead;
  232.     HNr  : word;
  233.     MUf  : UfMask absolute Ufr;
  234. begin
  235. with Ufr do
  236. begin
  237. if MUf.Handle<5  then begin UniResult:=NoUniAss;   exit end;
  238. if not MUf.Exist then begin UniResult:=NoUniExist; exit end;
  239. if Nr>MUf.MaxK   then begin UniResult:=UniInvRec;  exit end;
  240. reset(Uf,1);
  241. HNr:=0;
  242.    repeat
  243.    ReadHead(Ufr,Head);
  244.    if UniResult<0 then exit;
  245.       inc(HNr);
  246.       seek(Uf,FilePos(Uf)+DSize(Head));
  247.    until HNr=Nr;
  248. close(Uf);
  249. Inf.max   := Head.max;
  250. Inf.XPack := Head.HWModeX;
  251. Inf.YPack := Head.HWModeY;
  252. Inf.Info  := Head.HInfo;
  253. UniResult := UniOK;
  254. end;
  255. end;
  256.  
  257. Procedure ShortenPointer(var SP:Pointer);
  258. var P : PRec absolute SP;
  259. begin
  260. P.S:=P.S+P.O div 16;
  261. P.O:=P.O mod 16;
  262. end;
  263.  
  264.  
  265. Function E(k:Pointer; i:word; Typ:UType):extended;
  266. var P         : PRec absolute k;
  267.     PReal     : ^Real     absolute k;
  268.     PSingle   : ^Single   absolute k;
  269.     PDouble   : ^Double   absolute k;
  270.     PExtended : ^Extended absolute k;
  271.     PComp     : ^Comp     absolute k;
  272. begin
  273. inc(P.O,i*TS(Typ));
  274.    case Typ of
  275.    UReal       : E := PReal^;
  276.    USingle     : E := PSingle^;
  277.    UDouble     : E := PDouble^;
  278.    UExtended   : E := PExtended^;
  279.    UComp       : E := PComp^;
  280.    else
  281.    RunError(99);
  282.    end;
  283. end;
  284.  
  285. Function L(k:Pointer; i:word; Typ:UType):Longint;
  286. var P         : PRec absolute k;
  287.     PShortInt : ^ShortInt absolute k;
  288.     PByte     : ^Byte     absolute k;
  289.     PWord     : ^Word     absolute k;
  290.     PInteger  : ^Integer  absolute k;
  291.     PLongint  : ^Longint  absolute k;
  292. begin
  293. inc(P.O,i*TS(Typ));
  294.    case Typ of
  295.    UShortInt   : L := PShortInt^;
  296.    UByte       : L := PByte^;
  297.    UWord       : L := PWord^;
  298.    UInteger    : L := PInteger^;
  299.    ULongint    : L := PLongint^;
  300.    else
  301.    RunError(99);
  302.    end;
  303. end;
  304.  
  305. Procedure SetZ(k:Pointer; i:word; ZTyp:UType; QTyp:CType; Z:Pointer);
  306. var P         : PRec absolute k;
  307.     PReal     : ^Real     absolute k;
  308.     PSingle   : ^Single   absolute k;
  309.     PDouble   : ^Double   absolute k;
  310.     PExtended : ^Extended absolute k;
  311.     PComp     : ^Comp     absolute k;
  312.     PShortInt : ^ShortInt absolute k;
  313.     PByte     : ^Byte     absolute k;
  314.     PWord     : ^Word     absolute k;
  315.     PInteger  : ^Integer  absolute k;
  316.     PLongint  : ^Longint  absolute k;
  317.     XReal     : ^Real     absolute z;
  318.     XSingle   : ^Single   absolute z;
  319.     XDouble   : ^Double   absolute z;
  320.     XExtended : ^Extended absolute z;
  321.     XComp     : ^Comp     absolute z;
  322.     XShortInt : ^ShortInt absolute z;
  323.     XByte     : ^Byte     absolute z;
  324.     XWord     : ^Word     absolute z;
  325.     XInteger  : ^Integer  absolute z;
  326.     XLongint  : ^Longint  absolute z;
  327.     X         : extended;
  328. begin
  329. inc(P.O,i*TS(ZTyp));
  330.    case QTyp of
  331.    USI : x := XShortInt^;
  332.    UBY : x := XByte^;
  333.    UWO : x := XWord^;
  334.    UIN : x := XInteger^;
  335.    ULO : x := XLongint^;
  336.    US  : x := XSingle^;
  337.    else
  338.    RunError(99);
  339.    end;
  340.    case ZTyp of
  341.    UShortInt   : PShortInt^ := round(x);
  342.    UByte       : PByte^     := round(x);
  343.    UWord       : PWord^     := round(x);
  344.    UInteger    : PInteger^  := round(x);
  345.    ULongint    : PLongint^  := round(x);
  346.    UReal       : PReal^     := x;
  347.    USingle     : PSingle^   := x;
  348.    UDouble     : PDouble^   := x;
  349.    UExtended   : PExtended^ := x;
  350.    UComp       : PComp^     := x;
  351.    else
  352.    RunError(99);
  353.    end;
  354. end;
  355.  
  356. Function Aequi(k:Pointer; max:word; var dx:single; T:UType):boolean;
  357. var dx1,dx2,d : extended;
  358.     w         : word;
  359. begin
  360. ShortenPointer(k);
  361. d:=E(k,1,T)-E(k,0,T);
  362. dx1:=(1-Toll)*d;
  363. dx2:=(1+Toll)*d;
  364. Aequi:=true;
  365.    for w:=2 to (max-1) do
  366.    begin
  367.    d:=abs(E(k,w,T)-E(k,w-1,T));
  368.    if (d<dx1) or (d>dx2) then begin Aequi:=false; exit end;
  369.    end;
  370. dx:=(E(k,max-1,T)-E(k,0,T))/(max-1);
  371. end;
  372.  
  373.  
  374. Procedure UniWrite (var Ufr:UniFile; xp,yp:Pointer;
  375.                       TMax:word; UID:string; T:UType);
  376. var  Head                : TUniDatHead;
  377.      MUf                 : UfMask absolute Ufr;
  378.      XMin,XMax,YMin,YMax : extended;
  379.      w,c                 : word;
  380.      x,y                 : single;
  381.      UniCompX,UniCompY   : boolean;
  382.      Tx : UType absolute T;
  383.      Ty : UType absolute T;
  384. begin
  385. UniCompX:=UniComp;
  386. UniCompY:=UniComp;
  387. UniResult:=MUf.AssErr; if UniResult<0 then exit;
  388. UniResult:=UniError;
  389. if TMax<2 then begin UniResult:=UniTooSmall; exit end;
  390. ShortenPointer(xp);
  391. ShortenPointer(yp);
  392. with Head do
  393. begin
  394. max:=TMax;
  395. HInfo:=UID;
  396.    if UniCompX
  397.    and (Tx in TSin) then begin
  398.                          if Aequi(xp,Max,x,Tx) then begin
  399.                                                     HWModeX:=UG;
  400.                                                     X0:=E(xp,0,Tx);
  401.                                                     XS:=x;
  402.                                                     end
  403.                                                else begin
  404.                                                     HWModeX:=UC;
  405.                                                     XMin:=E(xp,0,Tx);
  406.                                                     XMax:=XMin;
  407.                                                     for w:=1 to (Max-1) do
  408.                                                     begin
  409.                                                     x:=E(xp,w,Tx);
  410.                                                     if x<XMin then XMin:=x;
  411.                                                     if x>XMax then XMax:=x;
  412.                                                     end;
  413.                                                     X0:=XMin;
  414.                                                     XS:=(XMax-XMin)/MaxWord;
  415.                                                     if XS=0 then XS:=1;
  416.                                                     end;
  417.                          end
  418.                     else case Tx of
  419.                          UShortint  : HWModeX:=USI;
  420.                          UByte      : HWModeX:=UBY;
  421.                          UWord      : HWModeX:=UWO;
  422.                          UInteger   : HWModeX:=UIN;
  423.                          ULongint   : HWModeX:=ULO;
  424.                          else         HWModeX:=US;
  425.                          end;
  426.    if UniCompY
  427.    and (Ty in TSin) then begin
  428.                          if Aequi(yp,Max,y,Ty) then begin
  429.                                                     HWModeY:=UG;
  430.                                                     Y0:=E(yp,0,Ty);
  431.                                                     YS:=y;
  432.                                                     end
  433.                                                else begin
  434.                                                     HWModeY:=UC;
  435.                                                     YMin:=E(yp,0,Ty);
  436.                                                     YMax:=YMin;
  437.                                                     for w:=1 to (Max-1) do
  438.                                                     begin
  439.                                                     y:=E(yp,w,Ty);
  440.                                                     if y<YMin then YMin:=y;
  441.                                                     if y>YMax then YMax:=y;
  442.                                                     end;
  443.                                                     Y0:=YMin;
  444.                                                     YS:=(YMax-YMin)/MaxWord;
  445.                                                     if YS=0 then YS:=1;
  446.                                                     end;
  447.                                   end
  448.                     else case Ty of
  449.                          UShortint  : HWModeY:=USI;
  450.                          UByte      : HWModeY:=UBY;
  451.                          UWord      : HWModeY:=UWO;
  452.                          UInteger   : HWModeY:=UIN;
  453.                          ULongint   : HWModeY:=ULO;
  454.                          else         HWModeY:=US;
  455.                          end;
  456. end;
  457. Make_HSize(Head);
  458. With Ufr do
  459. begin
  460. if NewOne then rewrite(Uf,1)
  461.           else begin reset(Uf,1); seek(Uf,FileSize(Uf)) end;
  462. WriteHead(Ufr,Head);
  463. if UniResult<0 then exit;
  464. MUf.Exist:=true;
  465. inc(MUf.MaxK);
  466. with Head do
  467. begin
  468.    Case HWModeX of
  469.    UG       : { Tue nichts };
  470.    UC       : for w:=0 to Max-1 do
  471.               begin
  472.               c:=round((E(xp,w,Tx)-X0)/XS);
  473.               BlockWrite(Uf,c,2);
  474.               end;
  475.    USI,UBY,
  476.    UWO,UIN,
  477.    ULO      : begin
  478.               c:=Max*TCS[HWModeX];
  479.               BlockWrite(Uf,xp^,c);
  480.               end;
  481.    US       : for w:=0 to Max-1 do
  482.               begin
  483.               x:=E(xp,w,Tx);
  484.               BlockWrite(Uf,x,4);
  485.               end;
  486.    end;
  487.    Case HWModeY of
  488.    UG       : { Tue nichts };
  489.    UC       : for w:=0 to Max-1 do
  490.               begin
  491.               c:=round((E(yp,w,Ty)-Y0)/YS);
  492.               BlockWrite(Uf,c,2);
  493.               end;
  494.    USI,UBY,
  495.    UWO,UIN,
  496.    ULO      : begin
  497.               c:=Max*TCS[HWModeY];
  498.               BlockWrite(Uf,yp^,c);
  499.               end;
  500.    US       : for w:=0 to Max-1 do
  501.               begin
  502.               y:=E(yp,w,Ty);
  503.               BlockWrite(Uf,y,4);
  504.               end;
  505.    end;
  506.  
  507. end;
  508. close(Uf);
  509. UniResult:=UniOK;
  510. end;
  511. end;
  512.  
  513. Procedure UniRewrite;
  514. begin
  515. NewOne:=True;
  516. UniWrite (Ufr,xp,yp,TMax,UID,T);
  517. end;
  518.  
  519. Procedure UniAppend;
  520. begin
  521. NewOne:=false;
  522. UniWrite (Ufr,xp,yp,TMax,UID,T);
  523. end;
  524.  
  525.  
  526. Procedure UniRead;
  527. var  Head  : TUniDatHead;
  528.      HNr   : word;
  529.      MUf   : UfMask absolute Ufr;
  530.      w     : word;
  531.      x,y   : single;
  532.      dsi   : Shortint;
  533.      dby   : Byte;
  534.      dwo   : Word;
  535.      din   : Integer;
  536.      dlo   : Longint;
  537.      ds    : Single;
  538.      Tx    : UType absolute T;
  539.      Ty    : UType absolute T;
  540. begin
  541. UniResult:=MUf.AssErr; if UniResult<0 then exit;
  542. UniResult:=UniError;
  543. if not MUf.Exist then begin UniResult:=NoUniExist; exit end;
  544. if Nr>MUf.MaxK   then begin UniResult:=UniInvRec;  exit end;
  545. With Ufr do
  546. begin
  547. Reset(Uf,1);
  548. HNr:=1;
  549. ReadHead(Ufr,Head);
  550. if UniResult<0 then exit;
  551.    while Nr>HNr do
  552.    begin
  553.    seek(Uf,FilePos(Uf)+DSize(Head));
  554.    ReadHead(Ufr,Head);
  555.    inc(HNr);
  556.    end;
  557. with Head do
  558. begin
  559.    if TMax<>Max then
  560.    begin
  561.       if TMax>0 then
  562.       begin
  563.       FreeMem(xp,TMax*TS(Tx));
  564.       FreeMem(yp,TMax*TS(Ty));
  565.       end;
  566.    UniResult:=NoUniMem;
  567.    if MaxAvail<(Max*TS(Tx)) then exit;
  568.    GetMem(xp,Max*TS(Tx));
  569.    if MaxAvail<(Max*TS(Ty)) then begin FreeMem(xp,Max*TS(Tx)); exit end;
  570.    GetMem(yp,Max*TS(Ty));
  571.    TMax:=Max;
  572.    end;
  573. ShortenPointer(xp);
  574. ShortenPointer(yp);
  575. for w:=0 to Max-1 do
  576. begin
  577.    Case HWModeX of
  578.    UG  : begin
  579.          x:=X0+XS*w;
  580.          SetZ(xp,w,Tx,US,@x);
  581.          end;
  582.    UC  : begin
  583.          BlockRead(Uf,dwo,2);
  584.          x:=X0+XS*dwo;
  585.          SetZ(xp,w,Tx,US,@x);
  586.          end;
  587.    USI,
  588.    UBY,
  589.    UWO,
  590.    UIN,
  591.    ULO,
  592.    US  : begin
  593.          BlockRead(Uf,x,TCS[HWModeX]);
  594.          SetZ(xp,w,Tx,HWModeX,@x);
  595.          end;
  596.    end;
  597. end;
  598. for w:=0 to Max-1 do
  599. begin
  600.    Case HWModeY of
  601.    UG  : begin
  602.          y:=Y0+YS*w;
  603.          SetZ(yp,w,Ty,US,@y);
  604.          end;
  605.    UC  : begin
  606.          BlockRead(Uf,dwo,2);
  607.          y:=Y0+YS*dwo;
  608.          SetZ(yp,w,Ty,US,@y);
  609.          end;
  610.    USI,
  611.    UBY,
  612.    UWO,
  613.    UIN,
  614.    ULO,
  615.    US  : begin
  616.          BlockRead(Uf,y,TCS[HWModeY]);
  617.          SetZ(yp,w,Ty,HWModeY,@y);
  618.          end;
  619.    end;
  620. end;
  621. end;
  622. UniResult:=UniOK;
  623. Close(Uf);
  624. end;
  625. end;
  626.  
  627. end.