home *** CD-ROM | disk | FTP | other *** search
/ Computer Club Elmshorn Atari PD / CCE_PD.iso / pc / 0600 / CCE_0632.ZIP / CCE_0632 / GOBJ_111.ZIP / GOBJECTS.111 / SOURCE / SPDTEST / SPDTEST.PAS < prev    next >
Pascal/Delphi Source File  |  1994-03-26  |  12KB  |  459 lines
  1. program SpeedoTest; {$P-,X+}
  2.   { ACHTUNG: Aus irgend einem Grund läuft dieses Programm _nicht_
  3.              mit PP vom 30.06.93. Mit der Version vom 28.04.93
  4.              bzw. vom 13.10.93 läuft dagegen alles ohne Probleme!?! }
  5.  
  6. uses
  7.  
  8.     Tos,Gem,OTypes,OProcs,OWindows,ODialogs;
  9.  
  10. const
  11.  
  12.     {$I spdtest.i}
  13.  
  14. type
  15.  
  16.     TSpApplication = object(TApplication)
  17.         fntIndx,
  18.         fntColor: integer;
  19.         fntName : string;
  20.         procedure SetupVDI; virtual;
  21.         procedure InitInstance; virtual;
  22.         procedure InitMainWindow; virtual;
  23.     end;
  24.  
  25.     PSpWindow = ^TSpWindow;
  26.     TSpWindow = object(TWindow)
  27.         oldWidth: integer;
  28.         ts      : array [0..2] of string;
  29.         fs,
  30.         fy,
  31.         offs    : array [0..3] of integer;
  32.         function CanClose: boolean; virtual;
  33.         procedure GetWindowClass(var AWndClass: TWndClass); virtual;
  34.         function GetClassName: string; virtual;
  35.         procedure Paint(var PaintInfo: TPaintStruct); virtual;
  36.         procedure WMClick(mX,mY,KStat: integer); virtual;
  37.         procedure GetWorkMin(var minX,minY: integer); virtual;
  38.     end;
  39.  
  40.     TTransRec = record
  41.         fc,
  42.         bc: array [0..7] of integer
  43.     end;
  44.  
  45.     PSpDialog = ^TSpDialog;
  46.     TSpDialog = object(TDialog)
  47.         TransRec: TTransRec;
  48.         okBtn   : PButton;
  49.         function GetStyle: integer; virtual;
  50.         procedure WMClosed; virtual;
  51.         function OK: boolean; virtual;
  52.         function Cancel: boolean; virtual;
  53.         function Help: boolean; virtual;
  54.         procedure CallChanged(Indx: integer; dclk,edt,push: boolean); virtual;
  55.     end;
  56.  
  57.     PAbout = ^TAbout;
  58.     TAbout = object(TKeyMenu)
  59.         procedure Work; virtual;
  60.     end;
  61.  
  62.     PAttr = ^TAttr;
  63.     TAttr = object(TKeyMenu)
  64.         procedure Work; virtual;
  65.     end;
  66.  
  67.     PFont = ^TFont;
  68.     TFont = object(TKeyMenu)
  69.         procedure Work; virtual;
  70.     end;
  71.  
  72. var
  73.  
  74.     SpApp: TSpApplication;
  75.  
  76.  
  77. function vqt_name(handle,element_num: integer; var name: string; var index: integer): boolean;
  78.     var q: integer;
  79.  
  80.     begin
  81.         VDI_pb.control^[0]:=130;
  82.         VDI_pb.control^[1]:=0;
  83.         VDI_pb.control^[3]:=1;
  84.         VDI_pb.control^[6]:=handle;
  85.         VDI_pb.intin^[0]:=element_num;
  86.         vdi(@VDI_pb);
  87.         index:=VDI_pb.intout^[0];
  88.         name:='';
  89.         for q:=1 to 32 do name:=name+chr(VDI_pb.intout^[q]);
  90.         StrPTrim(name);
  91.         vqt_name:=(VDI_pb.intout^[33]=1)
  92.     end;
  93.  
  94.  
  95. procedure SpResource; external; {$L spdtest.o}
  96.  
  97.  
  98. procedure TSpApplication.SetupVDI;
  99.  
  100.     begin
  101.         Attr.Style:=Attr.Style or as_LoadFonts;
  102.         inherited SetupVDI;
  103.         vswr_mode(vdiHandle,MD_TRANS);
  104.         vst_alignment(vdiHandle,TA_LEFT,TA_ASCENT,GP.horAlign,GP.verAlign);
  105.         fntColor:=Blue;
  106.         vst_color(vdiHandle,fntColor)
  107.     end;
  108.  
  109.  
  110. procedure TSpApplication.InitInstance;
  111.  
  112.     begin
  113.         InitResource(@SpResource,nil);
  114.         LoadMenu(SPMENU);
  115.         new(PAbout,Init(@self,K_CTRL,Ctrl_A,SPABOUT,SPTITLE1));
  116.         new(PAttr,Init(@self,K_CTRL,Ctrl_T,SPATTR,SPTITLE3));
  117.         new(PFont,Init(@self,K_CTRL,Ctrl_Z,SPFONT,SPTITLE3));
  118.         inherited InitInstance;
  119.         SetQuit(SPQUIT,SPTITLE2)
  120.     end;
  121.  
  122.  
  123. procedure TSpApplication.InitMainWindow;
  124.     var q: integer;
  125.  
  126.     begin
  127.         if not(SpeedoActive) then
  128.             begin
  129.                 Alert(nil,1,STOP,'SpeedoGDOS ist _nicht_ aktiv!','&Abbruch');
  130.                 Quit
  131.             end
  132.         else
  133.             begin
  134.                 fntIndx:=-1;
  135.                 for q:=1 to (Attr.sysFonts+Attr.addFonts) do
  136.                     if vqt_name(vdiHandle,q,fntName,fntIndx) then break;
  137.                 if fntIndx=-1 then
  138.                     begin
  139.                         Alert(nil,1,STOP,'Keine Vektorfonts vorhanden!','&Abbruch');
  140.                         Quit
  141.                     end
  142.                 else
  143.                     begin
  144.                         new(PSpWindow,Init(nil,'SpeedoTest'));
  145.                         if (MainWindow=nil) or (ChkError<em_OK) then Status:=em_InvalidMainWindow
  146.                         else
  147.                             begin
  148.                                 MainWindow^.SetSubTitle(' Aktueller Font: '+fntName);
  149.                                 PSpWindow(MainWindow)^.oldWidth:=-1;
  150.                                 vst_font(vdiHandle,fntIndx)
  151.                             end
  152.                     end
  153.             end
  154.     end;
  155.  
  156.  
  157. function TSpWindow.CanClose: boolean;
  158.  
  159.     begin
  160.         CanClose:=false;
  161.         if inherited CanClose then
  162.             CanClose:=(Application^.Alert(nil,1,WAIT,'Wollen Sie "SpeedoTest" wirklich verlassen?','&Ja| &Nein ')=1)
  163.     end;
  164.  
  165.  
  166. procedure TSpWindow.GetWindowClass(var AWndClass: TWndClass);
  167.  
  168.     begin
  169.         inherited GetWindowClass(AWndClass);
  170.         with AWndClass do Style:=Style or cs_FullRedraw or cs_WorkBackground;
  171.         ts[0]:='ObjectGEM';
  172.         ts[1]:='für Pure Pascal';
  173.         ts[2]:='Softdesign ''94'
  174.     end;
  175.  
  176.  
  177. function TSpWindow.GetClassName: string;
  178.  
  179.     begin
  180.         GetClassName:='SpeedoTestWindow'
  181.     end;
  182.  
  183.  
  184. procedure TSpWindow.Paint(var PaintInfo: TPaintStruct);
  185.     var dummy,q: integer;
  186.         array8 : ARRAY_8;
  187.  
  188.     procedure getSize;
  189.         label _fsnew,_fsagain;
  190.  
  191.         var h,abw,old: integer;
  192.  
  193.         begin
  194.             SetSubTitle(' Neue Fontgrößen werden berechnet...');
  195.             BusyMouse;
  196.             ShowMouse;
  197.             fy[0]:=0;
  198.             q:=0;
  199.             repeat
  200.                 fy[q+1]:=fy[q];
  201.                 abw:=5;
  202.                 _fsnew:
  203.                 h:=round(Application^.Attr.MaxPX*(Application^.Attr.PixW/1000));
  204.                 fs[q]:=h shr 1;
  205.                 old:=0;
  206.                 _fsagain:
  207.                 vst_arbpt(vdiHandle,fs[q],dummy,dummy,dummy,dummy);
  208.                 vqt_f_extent(vdiHandle,ts[q],array8);
  209.                 dummy:=array8[2]-array8[0];
  210.                 if not(Between(dummy,Work.W-abw,Work.W+abw)) and not(bTst(Kbshift(-1),1)) then
  211.                     begin
  212.                         if fs[q]=old then
  213.                             begin
  214.                                 inc(abw,5);
  215.                                 goto _fsnew
  216.                             end;
  217.                         if dummy<Work.W then
  218.                             begin
  219.                                 old:=fs[q];
  220.                                 fs[q]:=(fs[q]+h) shr 1;
  221.                                 goto _fsagain
  222.                             end
  223.                         else
  224.                             begin
  225.                                 old:=fs[q];
  226.                                 h:=fs[q];
  227.                                 fs[q]:=fs[q] shr 1;
  228.                                 goto _fsagain
  229.                             end
  230.                     end;
  231.                 offs[q]:=-array8[0];
  232.                 inc(q);
  233.                 fy[q]:=fy[q]+array8[7]-array8[1]
  234.             until q>2;
  235.             HideMouse;
  236.             ArrowMouse;
  237.             SetSubTitle(' Aktueller Font: '+SpApp.fntName);
  238.             oldWidth:=Work.W
  239.         end;
  240.  
  241.     begin
  242.         if Work.W<>oldWidth then getSize;
  243.         for q:=0 to 2 do
  244.             begin
  245.                 vst_arbpt(vdiHandle,fs[q],dummy,dummy,dummy,dummy);
  246.                 v_ftext(vdiHandle,Work.X+offs[q],Work.Y+fy[q],ts[q]);
  247.             end
  248.     end;
  249.  
  250.  
  251. procedure TSpWindow.WMClick(mX,mY,KStat: integer);
  252.     var pu     : PPopup;
  253.         q,w,ret: integer;
  254.         idxs   : array [0..8] of integer;
  255.         nam    : array [0..8] of string;
  256.  
  257.     begin
  258.         new(pu,Init(@self,SPPOP,SPPOPUP));
  259.         if pu<>nil then
  260.             begin
  261.                 with pu^ do
  262.                     begin
  263.                         pX:=mX;
  264.                         pY:=mY;
  265.                         pFlag:=POP_CENTER;
  266.                         for q:=0 to 8 do
  267.                             begin
  268.                                 SetText(q,'  -------------------------------- ');
  269.                                 Uncheck(q);
  270.                                 Disable(q)
  271.                             end;
  272.                         w:=0;
  273.                         for q:=1 to (Application^.Attr.sysFonts+Application^.Attr.addFonts) do
  274.                             if vqt_name(vdiHandle,q,nam[w],ret) then
  275.                                 begin
  276.                                     Enable(w);
  277.                                     SetText(w,'  '+nam[w]+StrPSpace(33-length(nam[w])));
  278.                                     if ret=SpApp.fntIndx then Check(w);
  279.                                     idxs[w]:=ret;
  280.                                     inc(w);
  281.                                     if w=9 then break
  282.                                 end;
  283.                         ret:=Execute
  284.                     end;
  285.                 dispose(pu,Done);
  286.                 if ret>=0 then
  287.                     if idxs[ret]<>SpApp.fntIndx then
  288.                         begin
  289.                             SpApp.fntIndx:=idxs[ret];
  290.                             SpApp.fntName:=nam[ret];
  291.                             oldWidth:=-1;
  292.                             vst_font(vdiHandle,idxs[ret]);
  293.                             SetSubTitle(' Aktueller Font: '+nam[ret]);
  294.                             ForceRedraw
  295.                         end
  296.             end
  297.     end;
  298.  
  299.  
  300. procedure TSpWindow.GetWorkMin(var minX,minY: integer);
  301.  
  302.     begin
  303.         inherited GetWorkMin(minX,minY);
  304.         inc(minX,50);
  305.         inc(minY,40)
  306.     end;
  307.  
  308.  
  309. function TSpDialog.GetStyle: integer;
  310.  
  311.     begin
  312.         GetStyle:=inherited GetStyle or SIZER or FULLER
  313.     end;
  314.  
  315.  
  316. procedure TSpDialog.WMClosed;
  317.  
  318.     begin
  319.         if CanClose then
  320.             if Cancel then Destroy
  321.     end;
  322.  
  323.  
  324. function TSpDialog.OK: boolean;
  325.     var q: integer;
  326.  
  327.     begin
  328.         inherited OK;
  329.         OK:=IsModal;
  330.         SpApp.fntColor:=0;
  331.         while TransRec.fc[SpApp.fntColor]=bf_Unchecked do inc(SpApp.fntColor);
  332.         vst_color(vdiHandle,SpApp.fntColor);
  333.         q:=0;
  334.         while TransRec.bc[q]=bf_Unchecked do inc(q);
  335.         Application^.MainWindow^.Class.hbrBackground:=succ(q);
  336.         Application^.MainWindow^.ForceRedraw
  337.     end;
  338.  
  339.  
  340. function TSpDialog.Cancel: boolean;
  341.     var valid: boolean;
  342.  
  343.     begin
  344.         valid:=inherited Cancel;
  345.         if valid then okBtn^.Enable;
  346.         Cancel:=valid
  347.     end;
  348.  
  349.  
  350. function TSpDialog.Help: boolean;
  351.  
  352.     begin
  353.         Application^.Alert(@self,1,NO_ICON,'In dieser Dialogbox werden die Schriftattribute eingestellt. Die neuen Werte werden übernommen, wenn Sie '#174'Setzen'#175' anklicken. Ist der Dialog nichtmodal, bleibt er auch nach dem Setzen aktiv!','  &OK  ');
  354.         Help:=false
  355.     end;
  356.  
  357.  
  358. procedure TSpDialog.CallChanged(Indx: integer; dclk,edt,push: boolean);
  359.     var tr   : TTransRec;
  360.         op   : pointer;
  361.         q1,q2: integer;
  362.  
  363.     begin
  364.         inherited CallChanged(Indx,dclk,edt,push);
  365.         op:=TransferBuffer;
  366.         TransferBuffer:=@tr;
  367.         TransferData(tf_GetData);
  368.         TransferBuffer:=op;
  369.         q1:=0;
  370.         while tr.fc[q1]=bf_Unchecked do inc(q1);
  371.         q2:=0;
  372.         while tr.bc[q2]=bf_Unchecked do inc(q2);
  373.         if q1=q2 then okBtn^.Disable
  374.         else
  375.             okBtn^.Enable
  376.     end;
  377.  
  378.  
  379. procedure TAbout.Work;
  380.  
  381.     begin
  382.         if ADialog=nil then
  383.             begin
  384.                 new(ADialog,Init(nil,'Über SpeedoTest',SABOUT));
  385.                 if ADialog<>nil then
  386.                     begin
  387.                         new(PGroupBox,Init(ADialog,IGROUP,'ObjectGEM SpeedoTest','"42"'));
  388.                         new(PButton,Init(ADialog,IOK,id_OK,true,'Mit diesem '+
  389.                                             'Button|kann die Infobox|verlassen werden.'))
  390.                     end
  391.             end;
  392.         if ADialog<>nil then ADialog^.MakeWindow
  393.     end;
  394.  
  395.  
  396. procedure TAttr.Work;
  397.     var q: integer;
  398.  
  399.     begin
  400.         if ADialog=nil then
  401.             begin
  402.                 ADialog:=new(PSpDialog,Init(nil,'Attribute',SATTR));
  403.                 if ADialog<>nil then
  404.                     begin
  405.                         new(PGroupBox,Init(ADialog,AFGROUP,'Schrift','Bestimmt die Schriftfarbe.'));
  406.                         new(PGroupBox,Init(ADialog,ABGROUP,'Hintergrund','Bestimmt die Farbe des|Fenster-Hintergrundes.'));
  407.                         new(PRadioButton,Init(ADialog,AFWHITE,true,'Setzt Weiß als|neue Schriftfarbe'));
  408.                         new(PRadioButton,Init(ADialog,AFBLACK,true,'Setzt Schwarz als|neue Schriftfarbe'));
  409.                         new(PRadioButton,Init(ADialog,AFRED,true,'Setzt Rot als|neue Schriftfarbe'));
  410.                         new(PRadioButton,Init(ADialog,AFGREEN,true,'Setzt Grün als|neue Schriftfarbe'));
  411.                         new(PRadioButton,Init(ADialog,AFBLUE,true,'Setzt Blau als|neue Schriftfarbe'));
  412.                         new(PRadioButton,Init(ADialog,AFCYAN,true,'Setzt Türkis als|neue Schriftfarbe'));
  413.                         new(PRadioButton,Init(ADialog,AFYELLOW,true,'Setzt Gelb als|neue Schriftfarbe'));
  414.                         new(PRadioButton,Init(ADialog,AFMAGENT,true,'Setzt Violett als|neue Schriftfarbe'));
  415.                         new(PRadioButton,Init(ADialog,ABWHITE,true,'Setzt Weiß als|neuen Hintergrund'));
  416.                         new(PRadioButton,Init(ADialog,ABBLACK,true,'Setzt Schwarz als|neuen Hintergrund'));
  417.                         new(PRadioButton,Init(ADialog,ABRED,true,'Setzt Rot als|neuen Hintergrund'));
  418.                         new(PRadioButton,Init(ADialog,ABGREEN,true,'Setzt Grün als|neuen Hintergrund'));
  419.                         new(PRadioButton,Init(ADialog,ABBLUE,true,'Setzt Blau als|neuen Hintergrund'));
  420.                         new(PRadioButton,Init(ADialog,ABCYAN,true,'Setzt Türkis als|neuen Hintergrund'));
  421.                         new(PRadioButton,Init(ADialog,ABYELLOW,true,'Setzt Gelb als|neuen Hintergrund'));
  422.                         new(PRadioButton,Init(ADialog,ABMAGENT,true,'Setzt Violett als|neuen Hintergrund'));
  423.                         new(PButton,Init(ADialog,AHELP,id_Help,true,'Zeigt einen Hilfstext|über diesen Dialog an.'));
  424.                         new(PSpDialog(ADialog)^.okBtn,Init(ADialog,AOK,id_OK,true,'Setzt die neuen Attribute,|_ohne_ den Dialog zu ver-|lassen.'));
  425.                         new(PButton,Init(ADialog,ACANCEL,id_Cancel,true,'Bricht den Dialog ab,|ohne die neuen Werte|zu übernehmen.'));
  426.                         with PSpDialog(ADialog)^ do
  427.                             begin
  428.                                 TransferBuffer:=@TransRec;
  429.                                 with TransRec do
  430.                                     begin
  431.                                         for q:=0 to 7 do
  432.                                             begin
  433.                                                 fc[q]:=bf_Unchecked;
  434.                                                 bc[q]:=bf_Unchecked
  435.                                             end;
  436.                                         fc[SpApp.fntColor]:=bf_Checked;
  437.                                         bc[pred(Application^.MainWindow^.Class.hbrBackground)]:=bf_Checked
  438.                                     end
  439.                             end
  440.                     end
  441.             end;
  442.         if ADialog<>nil then ADialog^.MakeWindow
  443.     end;
  444.  
  445.  
  446. procedure TFont.Work;
  447.     var x,y,bs,ks: integer;
  448.  
  449.     begin
  450.         graf_mkstate(x,y,bs,ks);
  451.         Application^.MainWindow^.WMClick(x,y,ks)
  452.     end;
  453.  
  454.  
  455. begin
  456.     SpApp.Init('STST','SpeedoTest');
  457.     SpApp.Run;
  458.     SpApp.Done
  459. end.