graph.pp 76 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 1999-2000 by Florian Klaempfl
  5. This file implements the win32 gui support for the graph unit
  6. See the file COPYING.FPC, included in this distribution,
  7. for details about the copyright.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  11. **********************************************************************}
  12. unit Graph;
  13. interface
  14. uses
  15. windows;
  16. {$i graphh.inc}
  17. var
  18. { this procedure allows to hook keyboard messages }
  19. charmessagehandler : function(Window: hwnd; AMessage, WParam,
  20. LParam: Longint): Longint;
  21. { this procedure allows to hook mouse messages }
  22. mousemessagehandler : function(Window: hwnd; AMessage, WParam,
  23. LParam: Longint): Longint;
  24. { this procedure allows to wm_command messages }
  25. commandmessagehandler : function(Window: hwnd; AMessage, WParam,
  26. LParam: Longint): Longint;
  27. NotifyMessageHandler : function(Window: hwnd; AMessage, WParam,
  28. LParam: Longint): Longint;
  29. OnGraphWindowCreation : procedure;
  30. GraphWindow,ParentWindow : HWnd;
  31. // this allows direct drawing to the window
  32. bitmapdc : hdc;
  33. windc : hdc;
  34. const
  35. { predefined window style }
  36. { we shouldn't set CS_DBLCLKS here }
  37. { because most dos applications }
  38. { handle double clicks on it's own }
  39. graphwindowstyle : DWord = cs_hRedraw or cs_vRedraw;
  40. windowtitle : pchar = 'Graph window application';
  41. menu : hmenu = 0;
  42. icon : hicon = 0;
  43. drawtoscreen : boolean = true;
  44. drawtobitmap : boolean = true;
  45. // the graph window can be a child window, this allows to add toolbars
  46. // to the main window
  47. UseChildWindow : boolean = false;
  48. // this allows to specify an offset for the child child window
  49. ChildOffset : rect = (left:0;top:0;right:0;bottom:0);
  50. CONST
  51. m640x200x16 = VGALo;
  52. m640x400x16 = VGAMed;
  53. m640x480x16 = VGAHi;
  54. { VESA Specific video modes. }
  55. m320x200x32k = $10D;
  56. m320x200x64k = $10E;
  57. m640x400x256 = $100;
  58. m640x480x256 = $101;
  59. m640x480x32k = $110;
  60. m640x480x64k = $111;
  61. m800x600x16 = $102;
  62. m800x600x256 = $103;
  63. m800x600x32k = $113;
  64. m800x600x64k = $114;
  65. m1024x768x16 = $104;
  66. m1024x768x256 = $105;
  67. m1024x768x32k = $116;
  68. m1024x768x64k = $117;
  69. m1280x1024x16 = $106;
  70. m1280x1024x256 = $107;
  71. m1280x1024x32k = $119;
  72. m1280x1024x64k = $11A;
  73. { some extra modes which applies only to GUI }
  74. mLargestWindow16 = $f0;
  75. mLargestWindow256 = $f1;
  76. mLargestWindow32k = $f2;
  77. mLargestWindow64k = $f3;
  78. mLargestWindow16M = $f4;
  79. mMaximizedWindow16 = $f5;
  80. mMaximizedWindow256 = $f6;
  81. mMaximizedWindow32k = $f7;
  82. mMaximizedWindow64k = $f8;
  83. mMaximizedWindow16M = $f9;
  84. implementation
  85. uses
  86. strings;
  87. {
  88. Remarks:
  89. Colors in 16 color mode:
  90. ------------------------
  91. - the behavior of xor/or/and put isn't 100%:
  92. it is done using the RGB color getting from windows
  93. instead of the palette index!
  94. - palette operations aren't supported
  95. To solve these drawbacks, setpalette must be implemented
  96. by exchanging the colors in the DCs, further GetPaletteEntry
  97. must be used when doing xor/or/and operations
  98. }
  99. const
  100. InternalDriverName = 'WIN32GUI';
  101. {$i graph.inc}
  102. { used to create a file containing all calls to WM_PAINT
  103. WARNING this probably creates HUGE files PM }
  104. { $define DEBUG_WM_PAINT}
  105. var
  106. savedscreen : hbitmap;
  107. graphrunning : boolean;
  108. graphdrawing : tcriticalsection;
  109. pens : array[0..15] of HPEN;
  110. {$ifdef DEBUG_WM_PAINT}
  111. graphdebug : text;
  112. const
  113. wm_paint_count : longint = 0;
  114. var
  115. {$endif DEBUG_WM_PAINT}
  116. oldbitmap : hgdiobj;
  117. pal : ^rgbrec;
  118. // SavePtr : pointer; { we don't use that pointer }
  119. MessageThreadHandle : Handle;
  120. MessageThreadID : DWord;
  121. function GetPaletteEntry(r,g,b : word) : word;
  122. var
  123. dist,i,index,currentdist : longint;
  124. begin
  125. dist:=$7fffffff;
  126. index:=0;
  127. for i:=0 to maxcolors do
  128. begin
  129. currentdist:=abs(r-pal[i].red)+abs(g-pal[i].green)+
  130. abs(b-pal[i].blue);
  131. if currentdist<dist then
  132. begin
  133. index:=i;
  134. dist:=currentdist;
  135. if dist=0 then
  136. break;
  137. end;
  138. end;
  139. GetPaletteEntry:=index;
  140. end;
  141. procedure PutPixel16Win32GUI(x,y : integer;pixel : word);
  142. var
  143. c : colorref;
  144. begin
  145. x:=x+startxviewport;
  146. y:=y+startyviewport;
  147. { convert to absolute coordinates and then verify clipping...}
  148. if clippixels then
  149. begin
  150. if (x<startxviewport) or (x>(startxviewport+viewwidth)) or
  151. (y<StartyViewPort) or (y>(startyviewport+viewheight)) then
  152. exit;
  153. end;
  154. if graphrunning then
  155. begin
  156. c:=RGB(pal[pixel].red,pal[pixel].green,pal[pixel].blue);
  157. EnterCriticalSection(graphdrawing);
  158. if drawtobitmap then
  159. SetPixelV(bitmapdc,x,y,c);
  160. if drawtoscreen then
  161. SetPixelV(windc,x,y,c);
  162. LeaveCriticalSection(graphdrawing);
  163. end;
  164. end;
  165. function GetPixel16Win32GUI(x,y : integer) : word;
  166. var
  167. c : COLORREF;
  168. begin
  169. x:=x+startxviewport;
  170. y:=y+startyviewport;
  171. { convert to absolute coordinates and then verify clipping...}
  172. if clippixels then
  173. begin
  174. if (x<startxviewport) or (x>(startxviewport+viewwidth)) or
  175. (y<StartyViewPort) or (y>(startyviewport+viewheight)) then
  176. exit;
  177. end;
  178. if graphrunning then
  179. begin
  180. EnterCriticalSection(graphdrawing);
  181. c:=Windows.GetPixel(bitmapdc,x,y);
  182. LeaveCriticalSection(graphdrawing);
  183. GetPixel16Win32GUI:=GetPaletteEntry(GetRValue(c),GetGValue(c),GetBValue(c));
  184. end
  185. else
  186. begin
  187. _graphresult:=grerror;
  188. exit;
  189. end;
  190. end;
  191. procedure DirectPutPixel16Win32GUI(x,y : integer);
  192. var
  193. col : longint;
  194. c,c2 : COLORREF;
  195. begin
  196. if graphrunning then
  197. begin
  198. EnterCriticalSection(graphdrawing);
  199. col:=CurrentColor;
  200. case currentwritemode of
  201. XorPut:
  202. Begin
  203. c2:=Windows.GetPixel(windc,x,y);
  204. c:=RGB(pal[col].red,pal[col].green,pal[col].blue) xor c2;
  205. if drawtobitmap then
  206. SetPixelV(bitmapdc,x,y,c);
  207. if drawtoscreen then
  208. SetPixelV(windc,x,y,c);
  209. End;
  210. AndPut:
  211. Begin
  212. c2:=Windows.GetPixel(windc,x,y);
  213. c:=RGB(pal[col].red,pal[col].green,pal[col].blue) and c2;
  214. if drawtobitmap then
  215. SetPixelV(bitmapdc,x,y,c);
  216. if drawtoscreen then
  217. SetPixelV(windc,x,y,c);
  218. End;
  219. OrPut:
  220. Begin
  221. c2:=Windows.GetPixel(windc,x,y);
  222. c:=RGB(pal[col].red,pal[col].green,pal[col].blue) or c2;
  223. if drawtobitmap then
  224. SetPixelV(bitmapdc,x,y,c);
  225. if drawtoscreen then
  226. SetPixelV(windc,x,y,c);
  227. End
  228. else
  229. Begin
  230. If CurrentWriteMode<>NotPut Then
  231. col:=CurrentColor
  232. Else col := Not(CurrentColor);
  233. c:=RGB(pal[col].red,pal[col].green,pal[col].blue);
  234. if drawtobitmap then
  235. SetPixelV(bitmapdc,x,y,c);
  236. if drawtoscreen then
  237. SetPixelV(windc,x,y,c);
  238. End
  239. end;
  240. LeaveCriticalSection(graphdrawing);
  241. end;
  242. end;
  243. var
  244. bitmapfontverticalcache : array[0..255] of HBITMAP;
  245. bitmapfonthorizoncache : array[0..255] of HBITMAP;
  246. procedure OutTextXYWin32GUI(x,y : smallint;const TextString : string);
  247. type
  248. Tpoint = record
  249. X,Y: smallint;
  250. end;
  251. var
  252. i,j,k,c : longint;
  253. xpos,ypos : longint;
  254. counter : longint;
  255. cnt1,cnt2 : smallint;
  256. cnt3,cnt4 : smallint;
  257. charsize : word;
  258. WriteMode : word;
  259. curX2, curY2, xpos2, ypos2, x2, y2: graph_float;
  260. oldvalues : linesettingstype;
  261. fontbitmap : TBitmapChar;
  262. chr : char;
  263. curx2i,cury2i,
  264. xpos2i,ypos2i : longint;
  265. charbitmap,oldcharbitmap : HBITMAP;
  266. chardc : HDC;
  267. color : longint;
  268. brushwin,oldbrushwin,brushbitmap,oldbrushbitmap : HBRUSH;
  269. bitmaprgn,winrgn : HRGN;
  270. begin
  271. { save current write mode }
  272. WriteMode := CurrentWriteMode;
  273. CurrentWriteMode := NormalPut;
  274. GetTextPosition(xpos,ypos,textstring);
  275. X:=X-XPos; Y:=Y+YPos;
  276. XPos:=X; YPos:=Y;
  277. CharSize := CurrentTextInfo.Charsize;
  278. if Currenttextinfo.font=DefaultFont then
  279. begin
  280. if CurrentTextInfo.direction=HorizDir then
  281. { Horizontal direction }
  282. begin
  283. if (x>viewwidth) or (y>viewheight) or
  284. (x<0) or (y<0) then
  285. begin
  286. CurrentWriteMode:=WriteMode;
  287. exit;
  288. end;
  289. EnterCriticalSection(graphdrawing);
  290. c:=length(textstring);
  291. chardc:=CreateCompatibleDC(windc);
  292. if currentcolor<>white then
  293. begin
  294. color:=RGB(pal[currentcolor].red,pal[currentcolor].green,
  295. pal[currentcolor].blue);
  296. if drawtoscreen then
  297. begin
  298. brushwin:=CreateSolidBrush(color);
  299. oldbrushwin:=SelectObject(windc,brushwin);
  300. end;
  301. if drawtobitmap then
  302. begin
  303. brushbitmap:=CreateSolidBrush(color);
  304. oldbrushbitmap:=SelectObject(bitmapdc,brushbitmap);
  305. end;
  306. end;
  307. inc(x,startxviewport);
  308. inc(y,startyviewport);
  309. { let windows do the clipping }
  310. if drawtobitmap then
  311. begin
  312. bitmaprgn:=CreateRectRgn(startxviewport,startyviewport,
  313. startxviewport+viewwidth+1,startyviewport+viewheight+1);
  314. SelectClipRgn(bitmapdc,bitmaprgn);
  315. end;
  316. if drawtoscreen then
  317. begin
  318. winrgn:=CreateRectRgn(startxviewport,startyviewport,
  319. startxviewport+viewwidth+1,startyviewport+viewheight+1);
  320. SelectClipRgn(windc,winrgn);
  321. end;
  322. for i:=0 to c-1 do
  323. begin
  324. xpos:=x+(i*8)*Charsize;
  325. if bitmapfonthorizoncache[byte(textstring[i+1])]=0 then
  326. begin
  327. charbitmap:=CreateCompatibleBitmap(windc,8,8);
  328. if charbitmap=0 then
  329. writeln('Bitmap konnte nicht erzeugt werden!');
  330. oldcharbitmap:=SelectObject(chardc,charbitmap);
  331. Fontbitmap:=TBitmapChar(DefaultFontData[textstring[i+1]]);
  332. for j:=0 to 7 do
  333. for k:=0 to 7 do
  334. if Fontbitmap[j,k]<>0 then
  335. SetPixelV(chardc,k,j,$ffffff)
  336. else
  337. SetPixelV(chardc,k,j,0);
  338. bitmapfonthorizoncache[byte(textstring[i+1])]:=charbitmap;
  339. SelectObject(chardc,oldcharbitmap);
  340. end;
  341. oldcharbitmap:=SelectObject(chardc,bitmapfonthorizoncache[byte(textstring[i+1])]);
  342. if CharSize=1 then
  343. begin
  344. if currentcolor=white then
  345. begin
  346. if drawtoscreen then
  347. BitBlt(windc,xpos,y,8,8,chardc,0,0,SRCPAINT);
  348. if drawtobitmap then
  349. BitBlt(bitmapdc,xpos,y,8,8,chardc,0,0,SRCPAINT);
  350. end
  351. else
  352. begin
  353. { could we do this with one pattern operation ?? }
  354. { we would need something like DSnaSPao }
  355. if drawtoscreen then
  356. begin
  357. // ROP $00220326=DSna
  358. BitBlt(windc,xpos,y,8,8,chardc,0,0,$00220326);
  359. // ROP $00EA02E9 = DPSao
  360. BitBlt(windc,xpos,y,8,8,chardc,0,0,$00EA02E9);
  361. end;
  362. if drawtobitmap then
  363. begin
  364. BitBlt(bitmapdc,xpos,y,8,8,chardc,0,0,$00220326);
  365. BitBlt(bitmapdc,xpos,y,8,8,chardc,0,0,$00EA02E9);
  366. end;
  367. end;
  368. end
  369. else
  370. begin
  371. if currentcolor=white then
  372. begin
  373. if drawtoscreen then
  374. StretchBlt(windc,xpos,y,8*charsize,8*charsize,chardc,0,0,8,8,SRCPAINT);
  375. if drawtobitmap then
  376. StretchBlt(bitmapdc,xpos,y,8*charsize,8*charsize,chardc,0,0,8,8,SRCPAINT);
  377. end
  378. else
  379. begin
  380. { could we do this with one pattern operation ?? }
  381. { we would need something like DSnaSPao }
  382. if drawtoscreen then
  383. begin
  384. // ROP $00220326=DSna
  385. StretchBlt(windc,xpos,y,8*charsize,8*charsize,chardc,0,0,8,8,$00220326);
  386. // ROP $00EA02E9 = DPSao
  387. StretchBlt(windc,xpos,y,8*charsize,8*charsize,chardc,0,0,8,8,$00EA02E9);
  388. end;
  389. if drawtobitmap then
  390. begin
  391. StretchBlt(bitmapdc,xpos,y,8*charsize,8*charsize,chardc,0,0,8,8,$00220326);
  392. StretchBlt(bitmapdc,xpos,y,8*charsize,8*charsize,chardc,0,0,8,8,$00EA02E9);
  393. end;
  394. end;
  395. end;
  396. SelectObject(chardc,oldcharbitmap);
  397. end;
  398. if currentcolor<>white then
  399. begin
  400. if drawtoscreen then
  401. begin
  402. SelectObject(windc,oldbrushwin);
  403. DeleteObject(brushwin);
  404. end;
  405. if drawtobitmap then
  406. begin
  407. SelectObject(bitmapdc,oldbrushbitmap);
  408. DeleteObject(brushbitmap);
  409. end;
  410. end;
  411. { release clip regions }
  412. if drawtobitmap then
  413. begin
  414. SelectClipRgn(bitmapdc,0);
  415. DeleteObject(bitmaprgn);
  416. end;
  417. if drawtoscreen then
  418. begin
  419. SelectClipRgn(windc,0);
  420. DeleteObject(winrgn);
  421. end;
  422. DeleteDC(chardc);
  423. LeaveCriticalSection(graphdrawing);
  424. end
  425. else
  426. { Vertical direction }
  427. begin
  428. if (x>viewwidth) or (y>viewheight) or
  429. (x<0) or (y<0) then
  430. begin
  431. CurrentWriteMode:=WriteMode;
  432. exit;
  433. end;
  434. EnterCriticalSection(graphdrawing);
  435. c:=length(textstring);
  436. chardc:=CreateCompatibleDC(windc);
  437. if currentcolor<>white then
  438. begin
  439. color:=RGB(pal[currentcolor].red,pal[currentcolor].green,
  440. pal[currentcolor].blue);
  441. if drawtoscreen then
  442. begin
  443. brushwin:=CreateSolidBrush(color);
  444. oldbrushwin:=SelectObject(windc,brushwin);
  445. end;
  446. if drawtobitmap then
  447. begin
  448. brushbitmap:=CreateSolidBrush(color);
  449. oldbrushbitmap:=SelectObject(bitmapdc,brushbitmap);
  450. end;
  451. end;
  452. inc(x,startxviewport);
  453. inc(y,startyviewport);
  454. { let windows do the clipping }
  455. if drawtoscreen then
  456. begin
  457. winrgn:=CreateRectRgn(startxviewport,startyviewport,
  458. startxviewport+viewwidth+1,startyviewport+viewheight+1);
  459. SelectClipRgn(windc,winrgn);
  460. end;
  461. if drawtobitmap then
  462. begin
  463. bitmaprgn:=CreateRectRgn(startxviewport,startyviewport,
  464. startxviewport+viewwidth+1,startyviewport+viewheight+1);
  465. SelectClipRgn(bitmapdc,bitmaprgn);
  466. end;
  467. for i:=0 to c-1 do
  468. begin
  469. ypos:=y+1-((i+1)*8)*CharSize;
  470. if bitmapfontverticalcache[byte(textstring[i+1])]=0 then
  471. begin
  472. charbitmap:=CreateCompatibleBitmap(windc,8,8);
  473. if charbitmap=0 then
  474. writeln('Bitmap konnte nicht erzeugt werden!');
  475. oldcharbitmap:=SelectObject(chardc,charbitmap);
  476. Fontbitmap:=TBitmapChar(DefaultFontData[textstring[i+1]]);
  477. for j:=0 to 7 do
  478. for k:=0 to 7 do
  479. if Fontbitmap[j,k]<>0 then
  480. SetPixelV(chardc,j,7-k,$ffffff)
  481. else
  482. SetPixelV(chardc,j,7-k,0);
  483. bitmapfontverticalcache[byte(textstring[i+1])]:=charbitmap;
  484. SelectObject(chardc,oldcharbitmap);
  485. end;
  486. oldcharbitmap:=SelectObject(chardc,bitmapfontverticalcache[byte(textstring[i+1])]);
  487. if CharSize=1 then
  488. begin
  489. if currentcolor=white then
  490. begin
  491. if drawtoscreen then
  492. BitBlt(windc,x,ypos,8,8,chardc,0,0,SRCPAINT);
  493. if drawtobitmap then
  494. BitBlt(bitmapdc,x,ypos,8,8,chardc,0,0,SRCPAINT);
  495. end
  496. else
  497. begin
  498. { could we do this with one pattern operation ?? }
  499. { we would need something like DSnaSPao }
  500. if drawtoscreen then
  501. begin
  502. // ROP $00220326=DSna
  503. BitBlt(windc,x,ypos,8,8,chardc,0,0,$00220326);
  504. // ROP $00EA02E9 = DPSao
  505. BitBlt(windc,x,ypos,8,8,chardc,0,0,$00EA02E9);
  506. end;
  507. if drawtobitmap then
  508. begin
  509. BitBlt(bitmapdc,x,ypos,8,8,chardc,0,0,$00220326);
  510. BitBlt(bitmapdc,x,ypos,8,8,chardc,0,0,$00EA02E9);
  511. end;
  512. end;
  513. end
  514. else
  515. begin
  516. if currentcolor=white then
  517. begin
  518. if drawtoscreen then
  519. StretchBlt(windc,x,ypos,8*charsize,8*charsize,chardc,0,0,8,8,SRCPAINT);
  520. if drawtobitmap then
  521. StretchBlt(bitmapdc,x,ypos,8*charsize,8*charsize,chardc,0,0,8,8,SRCPAINT);
  522. end
  523. else
  524. begin
  525. { could we do this with one pattern operation ?? }
  526. { we would need something like DSnaSPao }
  527. if drawtoscreen then
  528. begin
  529. // ROP $00220326=DSna
  530. StretchBlt(windc,x,ypos,8*charsize,8*charsize,chardc,0,0,8,8,$00220326);
  531. // ROP $00EA02E9 = DPSao
  532. StretchBlt(windc,x,ypos,8*charsize,8*charsize,chardc,0,0,8,8,$00EA02E9);
  533. end;
  534. if drawtobitmap then
  535. begin
  536. StretchBlt(bitmapdc,x,ypos,8*charsize,8*charsize,chardc,0,0,8,8,$00220326);
  537. StretchBlt(bitmapdc,x,ypos,8*charsize,8*charsize,chardc,0,0,8,8,$00EA02E9);
  538. end;
  539. end;
  540. end;
  541. SelectObject(chardc,oldcharbitmap);
  542. end;
  543. if currentcolor<>white then
  544. begin
  545. if drawtoscreen then
  546. begin
  547. SelectObject(windc,oldbrushwin);
  548. DeleteObject(brushwin);
  549. end;
  550. if drawtobitmap then
  551. begin
  552. SelectObject(bitmapdc,oldbrushbitmap);
  553. DeleteObject(brushbitmap);
  554. end;
  555. end;
  556. { release clip regions }
  557. if drawtoscreen then
  558. begin
  559. SelectClipRgn(windc,0);
  560. DeleteObject(winrgn);
  561. end;
  562. if drawtobitmap then
  563. begin
  564. SelectClipRgn(bitmapdc,0);
  565. DeleteObject(bitmaprgn);
  566. end;
  567. DeleteDC(chardc);
  568. LeaveCriticalSection(graphdrawing);
  569. end;
  570. end else
  571. { This is a stroked font which is already loaded into memory }
  572. begin
  573. getlinesettings(oldvalues);
  574. { reset line style to defaults }
  575. setlinestyle(solidln,oldvalues.pattern,normwidth);
  576. if Currenttextinfo.direction=vertdir then
  577. xpos:=xpos + Textheight(textstring);
  578. CurX2:=xpos; xpos2 := curX2; x2 := xpos2;
  579. CurY2:=ypos; ypos2 := curY2; y2 := ypos2;
  580. { x:=xpos; y:=ypos;}
  581. for i:=1 to length(textstring) do
  582. begin
  583. c:=byte(textstring[i]);
  584. { Stroke_Count[c] := }
  585. unpack( fonts[CurrentTextInfo.font].instr,
  586. fonts[CurrentTextInfo.font].Offsets[c], Strokes );
  587. counter:=0;
  588. while true do
  589. begin
  590. if CurrentTextInfo.direction=VertDir then
  591. begin
  592. xpos2:=x2-(Strokes[counter].Y*CurrentYRatio);
  593. ypos2:=y2-(Strokes[counter].X*CurrentXRatio);
  594. end
  595. else
  596. begin
  597. xpos2:=x2+(Strokes[counter].X*CurrentXRatio) ;
  598. ypos2:=y2-(Strokes[counter].Y*CurrentYRatio) ;
  599. end;
  600. case opcodes(Strokes[counter].opcode) of
  601. _END_OF_CHAR: break;
  602. _DO_SCAN: begin
  603. { Currently unsupported };
  604. end;
  605. _MOVE : Begin
  606. CurX2 := XPos2;
  607. CurY2 := YPos2;
  608. end;
  609. _DRAW: Begin
  610. curx2i:=trunc(CurX2);
  611. cury2i:=trunc(CurY2);
  612. xpos2i:=trunc(xpos2);
  613. ypos2i:=trunc(ypos2);
  614. { this optimization doesn't matter that much
  615. if (curx2i=xpos2i) then
  616. begin
  617. if (cury2i=ypos2i) then
  618. putpixel(curx2i,cury2i,currentcolor)
  619. else if (cury2i+1=ypos2i) or
  620. (cury2i=ypos2i+1) then
  621. begin
  622. putpixel(curx2i,cury2i,currentcolor);
  623. putpixel(curx2i,ypos2i,currentcolor);
  624. end
  625. else
  626. Line(curx2i,cury2i,xpos2i,ypos2i);
  627. end
  628. else if (cury2i=ypos2i) then
  629. begin
  630. if (curx2i+1=xpos2i) or
  631. (curx2i=xpos2i+1) then
  632. begin
  633. putpixel(curx2i,cury2i,currentcolor);
  634. putpixel(xpos2i,cury2i,currentcolor);
  635. end
  636. else
  637. Line(curx2i,cury2i,xpos2i,ypos2i);
  638. end
  639. else
  640. }
  641. Line(curx2i,cury2i,xpos2i,ypos2i);
  642. CurX2:=xpos2;
  643. CurY2:=ypos2;
  644. end;
  645. else
  646. Begin
  647. end;
  648. end;
  649. Inc(counter);
  650. end; { end while }
  651. if Currenttextinfo.direction=VertDir then
  652. y2:=y2-(byte(fonts[CurrenttextInfo.font].widths[c])*CurrentXRatio)
  653. else
  654. x2:=x2+(byte(fonts[Currenttextinfo.font].widths[c])*CurrentXRatio);
  655. end;
  656. setlinestyle( oldvalues.linestyle, oldvalues.pattern, oldvalues.thickness);
  657. end;
  658. { restore write mode }
  659. CurrentWriteMode := WriteMode;
  660. end;
  661. procedure HLine16Win32GUI(x,x2,y: integer);
  662. var
  663. c,c2 : COLORREF;
  664. col,i : longint;
  665. oldpen,pen : HPEN;
  666. Begin
  667. if graphrunning then
  668. begin
  669. { must we swap the values? }
  670. if x>x2 then
  671. Begin
  672. x:=x xor x2;
  673. x2:=x xor x2;
  674. x:=x xor x2;
  675. end;
  676. if ClipPixels then
  677. begin
  678. if (x>ViewWidth) or (y<0) or (y>ViewHeight) or (x2<0) then
  679. exit;
  680. if x<0 then
  681. x:=0;
  682. if x2>ViewWidth then
  683. x2:=ViewWidth;
  684. end;
  685. X:=X+StartXViewPort;
  686. X2:=X2+StartXViewPort;
  687. Y:=Y+StartYViewPort;
  688. Case CurrentWriteMode of
  689. AndPut:
  690. Begin
  691. EnterCriticalSection(graphdrawing);
  692. col:=CurrentColor;
  693. for i:=x to x2 do
  694. begin
  695. c2:=Windows.GetPixel(windc,i,y);
  696. c:=RGB(pal[col].red,pal[col].green,pal[col].blue) and c2;
  697. if drawtobitmap then
  698. SetPixelV(bitmapdc,i,y,c);
  699. if drawtoscreen then
  700. SetPixelV(windc,i,y,c);
  701. end;
  702. LeaveCriticalSection(graphdrawing);
  703. End;
  704. XorPut:
  705. Begin
  706. EnterCriticalSection(graphdrawing);
  707. col:=CurrentColor;
  708. for i:=x to x2 do
  709. begin
  710. c2:=Windows.GetPixel(windc,i,y);
  711. c:=RGB(pal[col].red,pal[col].green,pal[col].blue) xor c2;
  712. if drawtobitmap then
  713. SetPixelV(bitmapdc,i,y,c);
  714. if drawtoscreen then
  715. SetPixelV(windc,i,y,c);
  716. end;
  717. LeaveCriticalSection(graphdrawing);
  718. End;
  719. OrPut:
  720. Begin
  721. EnterCriticalSection(graphdrawing);
  722. col:=CurrentColor;
  723. for i:=x to x2 do
  724. begin
  725. c2:=Windows.GetPixel(windc,i,y);
  726. c:=RGB(pal[col].red,pal[col].green,pal[col].blue) or c2;
  727. if drawtobitmap then
  728. SetPixelV(bitmapdc,i,y,c);
  729. if drawtoscreen then
  730. SetPixelV(windc,i,y,c);
  731. end;
  732. LeaveCriticalSection(graphdrawing);
  733. End
  734. Else
  735. Begin
  736. If CurrentWriteMode<>NotPut Then
  737. col:=CurrentColor
  738. Else col:=Not(CurrentColor);
  739. EnterCriticalSection(graphdrawing);
  740. if x2-x<=2 then
  741. begin
  742. c:=RGB(pal[col].red,pal[col].green,pal[col].blue);
  743. for x := x to x2 do
  744. begin
  745. if drawtobitmap then
  746. SetPixelV(bitmapdc,x,y,c);
  747. if drawtoscreen then
  748. SetPixelV(windc,x,y,c);
  749. end;
  750. end
  751. else
  752. begin
  753. if (col>=0) and (col<=high(pens)) then
  754. begin
  755. if pens[col]=0 then
  756. begin
  757. c:=RGB(pal[col].red,pal[col].green,pal[col].blue);
  758. pens[col]:=CreatePen(PS_SOLID,1,c);
  759. end;
  760. pen:=pens[col];
  761. end
  762. else
  763. begin
  764. c:=RGB(pal[col].red,pal[col].green,pal[col].blue);
  765. pen:=CreatePen(PS_SOLID,1,c);
  766. end;
  767. if drawtobitmap then
  768. begin
  769. oldpen:=SelectObject(bitmapdc,pen);
  770. Windows.MoveToEx(bitmapdc,x,y,nil);
  771. Windows.LineTo(bitmapdc,x2+1,y);
  772. SelectObject(bitmapdc,oldpen);
  773. end;
  774. if drawtoscreen then
  775. begin
  776. oldpen:=SelectObject(windc,pen);
  777. Windows.MoveToEx(windc,x,y,nil);
  778. Windows.LineTo(windc,x2+1,y);
  779. SelectObject(windc,oldpen);
  780. end;
  781. if (col<0) or (col>high(pens)) then
  782. DeleteObject(pen);
  783. end;
  784. LeaveCriticalSection(graphdrawing);
  785. End;
  786. End;
  787. end;
  788. end;
  789. procedure VLine16Win32GUI(x,y,y2: smallint); {$ifndef fpc}far;{$endif fpc}
  790. var
  791. ytmp: smallint;
  792. col,c : longint;
  793. oldpen,pen : HPEN;
  794. Begin
  795. { must we swap the values? }
  796. if y >= y2 then
  797. Begin
  798. ytmp := y2;
  799. y2 := y;
  800. y:= ytmp;
  801. end;
  802. if ClipPixels then
  803. begin
  804. if (x>ViewWidth) or (x<0) or (y>ViewHeight) or (y2<0) then
  805. exit;
  806. if y<0 then
  807. y:=0;
  808. if y2>ViewHeight then
  809. y2:=ViewHeight;
  810. end;
  811. { First convert to global coordinates }
  812. X := X + StartXViewPort;
  813. Y2 := Y2 + StartYViewPort;
  814. Y := Y + StartYViewPort;
  815. if currentwritemode=normalput then
  816. begin
  817. col:=CurrentColor;
  818. EnterCriticalSection(graphdrawing);
  819. if y2-y<=2 then
  820. begin
  821. c:=RGB(pal[col].red,pal[col].green,pal[col].blue);
  822. for y := y to y2 do
  823. begin
  824. if drawtobitmap then
  825. SetPixelV(bitmapdc,x,y,c);
  826. if drawtoscreen then
  827. SetPixelV(windc,x,y,c);
  828. end;
  829. end
  830. else
  831. begin
  832. if (col>=0) and (col<=high(pens)) then
  833. begin
  834. if pens[col]=0 then
  835. begin
  836. c:=RGB(pal[col].red,pal[col].green,pal[col].blue);
  837. pens[col]:=CreatePen(PS_SOLID,1,c);
  838. end;
  839. pen:=pens[col];
  840. end
  841. else
  842. begin
  843. c:=RGB(pal[col].red,pal[col].green,pal[col].blue);
  844. pen:=CreatePen(PS_SOLID,1,c);
  845. end;
  846. if drawtobitmap then
  847. begin
  848. oldpen:=SelectObject(bitmapdc,pen);
  849. Windows.MoveToEx(bitmapdc,x,y,nil);
  850. Windows.LineTo(bitmapdc,x,y2+1);
  851. SelectObject(bitmapdc,oldpen);
  852. end;
  853. if drawtoscreen then
  854. begin
  855. oldpen:=SelectObject(windc,pen);
  856. Windows.MoveToEx(windc,x,y,nil);
  857. Windows.LineTo(windc,x,y2+1);
  858. SelectObject(windc,oldpen);
  859. end;
  860. if (col<0) or (col>high(pens)) then
  861. DeleteObject(pen);
  862. end;
  863. LeaveCriticalSection(graphdrawing);
  864. end
  865. else
  866. for y := y to y2 do Directputpixel(x,y)
  867. End;
  868. procedure Circle16Win32GUI(X, Y: smallint; Radius:Word);
  869. var
  870. bitmaprgn,winrgn : HRGN;
  871. col,c : longint;
  872. oldpen,pen : HPEN;
  873. OriginalArcInfo: ArcCoordsType;
  874. OldWriteMode: word;
  875. begin
  876. if (Radius = 0) then
  877. Exit;
  878. if (Radius = 1) then
  879. begin
  880. { only normal put mode is supported by a call to PutPixel }
  881. PutPixel(X, Y, CurrentColor);
  882. Exit;
  883. end;
  884. if (Radius = 2) then
  885. begin
  886. { only normal put mode is supported by a call to PutPixel }
  887. PutPixel(X-1, Y, CurrentColor);
  888. PutPixel(X+1, Y, CurrentColor);
  889. PutPixel(X, Y-1, CurrentColor);
  890. PutPixel(X, Y+1, CurrentColor);
  891. Exit;
  892. end;
  893. if LineInfo.Thickness = Normwidth then
  894. begin
  895. EnterCriticalSection(graphdrawing);
  896. { let windows do the clipping }
  897. if drawtobitmap then
  898. begin
  899. bitmaprgn:=CreateRectRgn(startxviewport,startyviewport,
  900. startxviewport+viewwidth+1,startyviewport+viewheight+1);
  901. SelectClipRgn(bitmapdc,bitmaprgn);
  902. end;
  903. if drawtoscreen then
  904. begin
  905. winrgn:=CreateRectRgn(startxviewport,startyviewport,
  906. startxviewport+viewwidth+1,startyviewport+viewheight+1);
  907. SelectClipRgn(windc,winrgn);
  908. end;
  909. inc(x,StartXViewPort);
  910. inc(y,StartYViewPort);
  911. col:=CurrentColor;
  912. if (col>=0) and (col<=high(pens)) then
  913. begin
  914. if pens[col]=0 then
  915. begin
  916. c:=RGB(pal[col].red,pal[col].green,pal[col].blue);
  917. pens[col]:=CreatePen(PS_SOLID,1,c);
  918. end;
  919. pen:=pens[col];
  920. end
  921. else
  922. begin
  923. c:=RGB(pal[col].red,pal[col].green,pal[col].blue);
  924. pen:=CreatePen(PS_SOLID,1,c);
  925. end;
  926. if drawtobitmap then
  927. begin
  928. oldpen:=SelectObject(bitmapdc,pen);
  929. windows.arc(bitmapdc,x-radius,y-radius,x+radius,y+radius,
  930. x,y-radius,x,y-radius);
  931. SelectObject(bitmapdc,oldpen);
  932. end;
  933. if drawtoscreen then
  934. begin
  935. oldpen:=SelectObject(windc,pen);
  936. windows.arc(windc,x-radius,y-radius,x+radius,y+radius,
  937. x,y-radius,x,y-radius);
  938. SelectObject(windc,oldpen);
  939. end;
  940. if (col<0) or (col>high(pens)) then
  941. DeleteObject(pen);
  942. { release clip regions }
  943. if drawtoscreen then
  944. begin
  945. SelectClipRgn(windc,0);
  946. DeleteObject(winrgn);
  947. end;
  948. if drawtobitmap then
  949. begin
  950. SelectClipRgn(bitmapdc,0);
  951. DeleteObject(bitmaprgn);
  952. end;
  953. LeaveCriticalSection(graphdrawing);
  954. end
  955. else
  956. begin
  957. { save state of arc information }
  958. { because it is not needed for }
  959. { a circle call. }
  960. move(ArcCall,OriginalArcInfo, sizeof(ArcCall));
  961. InternalEllipse(X,Y,Radius,Radius,0,360,{$ifdef fpc}@{$endif}DummyPatternLine);
  962. { restore arc information }
  963. move(OriginalArcInfo, ArcCall,sizeof(ArcCall));
  964. end;
  965. end;
  966. {
  967. Procedure PutImageWin32GUI(X,Y: smallint; var Bitmap; BitBlt: Word); {$ifndef fpc}far;{$endif fpc}
  968. type
  969. pt = array[0..$fffffff] of word;
  970. ptw = array[0..2] of longint;
  971. var
  972. k: longint;
  973. oldCurrentColor: word;
  974. oldCurrentWriteMode, i, j, y1, x1, deltaX, deltaX1, deltaY: smallint;
  975. Begin
  976. {$ifdef logging}
  977. LogLn('putImage at ('+strf(x)+','+strf(y)+') with width '+strf(ptw(Bitmap)[0])+
  978. ' and height '+strf(ptw(Bitmap)[1]));
  979. deltaY := 0;
  980. {$endif logging}
  981. inc(x,startXViewPort);
  982. inc(y,startYViewPort);
  983. x1 := ptw(Bitmap)[0]+x; { get width and adjust end coordinate accordingly }
  984. y1 := ptw(Bitmap)[1]+y; { get height and adjust end coordinate accordingly }
  985. deltaX := 0;
  986. deltaX1 := 0;
  987. k := 3 * sizeOf(Longint) div sizeOf(Word); { Three reserved longs at start of bitmap }
  988. { check which part of the image is in the viewport }
  989. if clipPixels then
  990. begin
  991. if y < startYViewPort then
  992. begin
  993. deltaY := startYViewPort - y;
  994. inc(k,(x1-x+1)*deltaY);
  995. y := startYViewPort;
  996. end;
  997. if y1 > startYViewPort+viewHeight then
  998. y1 := startYViewPort+viewHeight;
  999. if x < startXViewPort then
  1000. begin
  1001. deltaX := startXViewPort-x;
  1002. x := startXViewPort;
  1003. end;
  1004. if x1 > startXViewPort + viewWidth then
  1005. begin
  1006. deltaX1 := x1 - (startXViewPort + viewWidth);
  1007. x1 := startXViewPort + viewWidth;
  1008. end;
  1009. end;
  1010. {$ifdef logging}
  1011. LogLn('deltax: '+strf(deltax)+', deltax1: '+strf(deltax1)+',deltay: '+strf(deltay));
  1012. {$endif logging}
  1013. case bitBlt of
  1014. end;
  1015. oldCurrentColor := currentColor;
  1016. oldCurrentWriteMode := currentWriteMode;
  1017. currentWriteMode := bitBlt;
  1018. for j:=Y to Y1 do
  1019. Begin
  1020. inc(k,deltaX);
  1021. for i:=X to X1 do
  1022. begin
  1023. currentColor := pt(bitmap)[k];
  1024. directPutPixel(i,j);
  1025. inc(k);
  1026. end;
  1027. inc(k,deltaX1);
  1028. end;
  1029. currentWriteMode := oldCurrentWriteMode;
  1030. currentColor := oldCurrentColor;
  1031. end;
  1032. }
  1033. procedure SetRGBPaletteWin32GUI(colorNum,redValue,greenvalue,
  1034. bluevalue : integer);
  1035. begin
  1036. if directcolor or (colornum<0) or (colornum>=maxcolor) then
  1037. begin
  1038. _graphresult:=grerror;
  1039. exit;
  1040. end;
  1041. pal[colorNum].red:=redValue;
  1042. pal[colorNum].green:=greenValue;
  1043. pal[colorNum].blue:=blueValue;
  1044. end;
  1045. procedure GetRGBPaletteWin32GUI(colorNum : integer;
  1046. var redValue,greenvalue,bluevalue : integer);
  1047. begin
  1048. if directcolor or (colornum<0) or (colornum>=maxcolor) then
  1049. begin
  1050. _graphresult:=grerror;
  1051. exit;
  1052. end;
  1053. redValue:=pal[colorNum].red;
  1054. greenValue:=pal[colorNum].green;
  1055. blueValue:=pal[colorNum].blue;
  1056. end;
  1057. procedure savestate;
  1058. begin
  1059. end;
  1060. procedure restorestate;
  1061. begin
  1062. end;
  1063. function WindowProcGraph(Window: HWnd; AMessage, WParam,
  1064. LParam: Longint): Longint; stdcall; export;
  1065. var
  1066. dc : hdc;
  1067. ps : paintstruct;
  1068. r : rect;
  1069. oldbrush : hbrush;
  1070. oldpen : hpen;
  1071. i : longint;
  1072. begin
  1073. WindowProcGraph := 0;
  1074. case AMessage of
  1075. wm_lbuttondown,
  1076. wm_rbuttondown,
  1077. wm_mbuttondown,
  1078. wm_lbuttonup,
  1079. wm_rbuttonup,
  1080. wm_mbuttonup,
  1081. wm_lbuttondblclk,
  1082. wm_rbuttondblclk,
  1083. wm_mbuttondblclk:
  1084. {
  1085. This leads to problem, i.e. the menu etc doesn't work any longer
  1086. wm_nclbuttondown,
  1087. wm_ncrbuttondown,
  1088. wm_ncmbuttondown,
  1089. wm_nclbuttonup,
  1090. wm_ncrbuttonup,
  1091. wm_ncmbuttonup,
  1092. wm_nclbuttondblclk,
  1093. wm_ncrbuttondblclk,
  1094. wm_ncmbuttondblclk:
  1095. }
  1096. begin
  1097. if assigned(mousemessagehandler) then
  1098. WindowProcGraph:=mousemessagehandler(window,amessage,wparam,lparam);
  1099. end;
  1100. wm_notify:
  1101. begin
  1102. if assigned(notifymessagehandler) then
  1103. WindowProcGraph:=notifymessagehandler(window,amessage,wparam,lparam);
  1104. end;
  1105. wm_command:
  1106. if assigned(commandmessagehandler) then
  1107. WindowProcGraph:=commandmessagehandler(window,amessage,wparam,lparam);
  1108. wm_keydown,
  1109. wm_keyup,
  1110. wm_char:
  1111. begin
  1112. if assigned(charmessagehandler) then
  1113. WindowProcGraph:=charmessagehandler(window,amessage,wparam,lparam);
  1114. end;
  1115. wm_paint:
  1116. begin
  1117. {$ifdef DEBUG_WM_PAINT}
  1118. inc(wm_paint_count);
  1119. {$endif DEBUG_WM_PAINT}
  1120. {$ifdef DEBUGCHILDS}
  1121. writeln('Start child painting');
  1122. {$endif DEBUGCHILDS}
  1123. if not GetUpdateRect(Window,@r,false) then
  1124. exit;
  1125. EnterCriticalSection(graphdrawing);
  1126. graphrunning:=true;
  1127. dc:=BeginPaint(Window,@ps);
  1128. {$ifdef DEBUG_WM_PAINT}
  1129. Writeln(graphdebug,'WM_PAINT in ((',r.left,',',r.top,
  1130. '),(',r.right,',',r.bottom,'))');
  1131. {$endif def DEBUG_WM_PAINT}
  1132. if graphrunning then
  1133. {BitBlt(dc,0,0,maxx+1,maxy+1,bitmapdc,0,0,SRCCOPY);}
  1134. BitBlt(dc,r.left,r.top,r.right-r.left+1,r.bottom-r.top+1,bitmapdc,r.left,r.top,SRCCOPY);
  1135. EndPaint(Window,ps);
  1136. LeaveCriticalSection(graphdrawing);
  1137. Exit;
  1138. end;
  1139. wm_create:
  1140. begin
  1141. {$ifdef DEBUG_WM_PAINT}
  1142. assign(graphdebug,'wingraph.log');
  1143. rewrite(graphdebug);
  1144. {$endif DEBUG_WM_PAINT}
  1145. {$ifdef DEBUGCHILDS}
  1146. writeln('Creating window (HWND: ',window,')... ');
  1147. {$endif DEBUGCHILDS}
  1148. GraphWindow:=window;
  1149. EnterCriticalSection(graphdrawing);
  1150. dc:=GetDC(window);
  1151. {$ifdef DEBUGCHILDS}
  1152. writeln('Window DC: ',dc);
  1153. {$endif DEBUGCHILDS}
  1154. bitmapdc:=CreateCompatibleDC(dc);
  1155. savedscreen:=CreateCompatibleBitmap(dc,maxx+1,maxy+1);
  1156. ReleaseDC(window,dc);
  1157. oldbitmap:=SelectObject(bitmapdc,savedscreen);
  1158. windc:=GetDC(window);
  1159. // clear everything
  1160. oldpen:=SelectObject(bitmapdc,GetStockObject(BLACK_PEN));
  1161. oldbrush:=SelectObject(bitmapdc,GetStockObject(BLACK_BRUSH));
  1162. Windows.Rectangle(bitmapdc,0,0,maxx,maxy);
  1163. SelectObject(bitmapdc,oldpen);
  1164. SelectObject(bitmapdc,oldbrush);
  1165. // ... the window too
  1166. oldpen:=SelectObject(windc,GetStockObject(BLACK_PEN));
  1167. oldbrush:=SelectObject(windc,GetStockObject(BLACK_BRUSH));
  1168. Windows.Rectangle(windc,0,0,maxx,maxy);
  1169. SelectObject(windc,oldpen);
  1170. SelectObject(windc,oldbrush);
  1171. // clear font cache
  1172. fillchar(bitmapfonthorizoncache,sizeof(bitmapfonthorizoncache),0);
  1173. fillchar(bitmapfontverticalcache,sizeof(bitmapfontverticalcache),0);
  1174. // clear predefined pens
  1175. fillchar(pens,sizeof(pens),0);
  1176. if assigned(OnGraphWindowCreation) then
  1177. OnGraphWindowCreation;
  1178. LeaveCriticalSection(graphdrawing);
  1179. {$ifdef DEBUGCHILDS}
  1180. writeln('done');
  1181. GetClientRect(window,@r);
  1182. writeln('Window size: ',r.right,',',r.bottom);
  1183. {$endif DEBUGCHILDS}
  1184. end;
  1185. wm_Destroy:
  1186. begin
  1187. EnterCriticalSection(graphdrawing);
  1188. graphrunning:=false;
  1189. ReleaseDC(GraphWindow,windc);
  1190. SelectObject(bitmapdc,oldbitmap);
  1191. DeleteObject(savedscreen);
  1192. DeleteDC(bitmapdc);
  1193. // release font cache
  1194. for i:=0 to 255 do
  1195. if bitmapfonthorizoncache[i]<>0 then
  1196. DeleteObject(bitmapfonthorizoncache[i]);
  1197. for i:=0 to 255 do
  1198. if bitmapfontverticalcache[i]<>0 then
  1199. DeleteObject(bitmapfontverticalcache[i]);
  1200. for i:=0 to high(pens) do
  1201. if pens[i]<>0 then
  1202. DeleteObject(pens[i]);
  1203. LeaveCriticalSection(graphdrawing);
  1204. {$ifdef DEBUG_WM_PAINT}
  1205. close(graphdebug);
  1206. {$endif DEBUG_WM_PAINT}
  1207. PostQuitMessage(0);
  1208. Exit;
  1209. end
  1210. else
  1211. WindowProcGraph := DefWindowProc(Window, AMessage, WParam, LParam);
  1212. end;
  1213. end;
  1214. function WindowProcParent(Window: HWnd; AMessage, WParam,
  1215. LParam: Longint): Longint; stdcall; export;
  1216. begin
  1217. WindowProcParent := 0;
  1218. case AMessage of
  1219. wm_keydown,
  1220. wm_keyup,
  1221. wm_char:
  1222. begin
  1223. if assigned(charmessagehandler) then
  1224. WindowProcParent:=charmessagehandler(window,amessage,wparam,lparam);
  1225. end;
  1226. wm_notify:
  1227. begin
  1228. if assigned(notifymessagehandler) then
  1229. WindowProcParent:=notifymessagehandler(window,amessage,wparam,lparam);
  1230. end;
  1231. wm_command:
  1232. if assigned(commandmessagehandler) then
  1233. WindowProcParent:=commandmessagehandler(window,amessage,wparam,lparam);
  1234. else
  1235. WindowProcParent := DefWindowProc(Window, AMessage, WParam, LParam);
  1236. end;
  1237. end;
  1238. function WinRegister: Boolean;
  1239. var
  1240. WindowClass: WndClass;
  1241. begin
  1242. WindowClass.Style := graphwindowstyle;
  1243. WindowClass.lpfnWndProc := WndProc(@WindowProcGraph);
  1244. WindowClass.cbClsExtra := 0;
  1245. WindowClass.cbWndExtra := 0;
  1246. WindowClass.hInstance := system.MainInstance;
  1247. if icon<>0 then
  1248. WindowClass.hIcon := icon
  1249. else
  1250. WindowClass.hIcon := LoadIcon(0, idi_Application);
  1251. WindowClass.hCursor := LoadCursor(0, idc_Arrow);
  1252. WindowClass.hbrBackground := GetStockObject(BLACK_BRUSH);
  1253. if menu<>0 then
  1254. WindowClass.lpszMenuName := MAKEINTRESOURCE(menu)
  1255. else
  1256. WindowClass.lpszMenuName := nil;
  1257. WindowClass.lpszClassName := 'FPCGraphWindow';
  1258. winregister:=RegisterClass(WindowClass) <> 0;
  1259. end;
  1260. function WinRegisterWithChild: Boolean;
  1261. var
  1262. WindowClass: WndClass;
  1263. begin
  1264. WindowClass.Style := graphwindowstyle;
  1265. WindowClass.lpfnWndProc := WndProc(@WindowProcParent);
  1266. WindowClass.cbClsExtra := 0;
  1267. WindowClass.cbWndExtra := 0;
  1268. WindowClass.hInstance := system.MainInstance;
  1269. if icon<>0 then
  1270. WindowClass.hIcon := icon
  1271. else
  1272. WindowClass.hIcon := LoadIcon(0, idi_Application);
  1273. WindowClass.hCursor := LoadCursor(0, idc_Arrow);
  1274. WindowClass.hbrBackground := GetStockObject(BLACK_BRUSH);
  1275. if menu<>0 then
  1276. WindowClass.lpszMenuName := MAKEINTRESOURCE(menu)
  1277. else
  1278. WindowClass.lpszMenuName := nil;
  1279. WindowClass.lpszClassName := 'FPCGraphWindowMain';
  1280. WinRegisterWithChild:=RegisterClass(WindowClass) <> 0;
  1281. {$ifdef DEBUGCHILDS}
  1282. writeln('Main window successfully registered: WinRegisterWithChild is ',WinRegisterWithChild);
  1283. {$endif DEBUGCHILDS}
  1284. if WinRegisterWithChild then
  1285. begin
  1286. WindowClass.Style := CS_HREDRAW or CS_VREDRAW;
  1287. WindowClass.lpfnWndProc := WndProc(@WindowProcGraph);
  1288. WindowClass.cbClsExtra := 0;
  1289. WindowClass.cbWndExtra := 0;
  1290. WindowClass.hInstance := system.MainInstance;
  1291. WindowClass.hIcon := 0;
  1292. WindowClass.hCursor := LoadCursor(0, idc_Arrow);
  1293. WindowClass.hbrBackground := GetStockObject(BLACK_BRUSH);
  1294. WindowClass.lpszMenuName := nil;
  1295. WindowClass.lpszClassName := 'FPCGraphWindowChild';
  1296. WinRegisterWithChild:=RegisterClass(WindowClass)<>0;
  1297. {$ifdef DEBUGCHILDS}
  1298. writeln('Child window registered: WinRegisterWithChild is ',WinRegisterWithChild);
  1299. {$endif DEBUGCHILDS}
  1300. end;
  1301. end;
  1302. var
  1303. // here we can force the creation of a maximized window }
  1304. extrastyle : cardinal;
  1305. { Create the Window Class }
  1306. function WinCreate : HWnd;
  1307. var
  1308. hWindow: HWnd;
  1309. begin
  1310. WinCreate:=0;
  1311. if UseChildWindow then
  1312. begin
  1313. ParentWindow:=CreateWindow('FPCGraphWindowMain', windowtitle,
  1314. WS_OVERLAPPEDWINDOW or WS_CLIPCHILDREN or extrastyle, longint(CW_USEDEFAULT), 0,
  1315. maxx+ChildOffset.Left+ChildOffset.Right+1+
  1316. 2*GetSystemMetrics(SM_CXFRAME),
  1317. maxy+ChildOffset.Top+ChildOffset.Bottom+1+
  1318. 2*GetSystemMetrics(SM_CYFRAME)+
  1319. GetSystemMetrics(SM_CYCAPTION),
  1320. 0, 0, system.MainInstance, nil);
  1321. if ParentWindow<>0 then
  1322. begin
  1323. ShowWindow(ParentWindow, SW_SHOW);
  1324. UpdateWindow(ParentWindow);
  1325. end
  1326. else
  1327. exit;
  1328. hWindow:=CreateWindow('FPCGraphWindowChild',nil,
  1329. WS_CHILD, ChildOffset.Left,ChildOffset.Top,
  1330. maxx+1,maxy+1,
  1331. ParentWindow, 0, system.MainInstance, nil);
  1332. if hwindow<>0 then
  1333. begin
  1334. ShowWindow(hwindow, SW_SHOW);
  1335. UpdateWindow(hwindow);
  1336. end
  1337. else
  1338. exit;
  1339. WinCreate:=hWindow;
  1340. end
  1341. else
  1342. begin
  1343. hWindow:=CreateWindow('FPCGraphWindow', windowtitle,
  1344. ws_OverlappedWindow or extrastyle, longint(CW_USEDEFAULT), 0,
  1345. maxx+1+2*GetSystemMetrics(SM_CXFRAME),
  1346. maxy+1+2*GetSystemMetrics(SM_CYFRAME)+
  1347. GetSystemMetrics(SM_CYCAPTION),
  1348. 0, 0, system.MainInstance, nil);
  1349. if hWindow <> 0 then
  1350. begin
  1351. ShowWindow(hWindow, SW_SHOW);
  1352. UpdateWindow(hWindow);
  1353. WinCreate:=hWindow;
  1354. end;
  1355. end;
  1356. end;
  1357. const
  1358. winregistered : boolean = false;
  1359. function MessageHandleThread(p : pointer) : DWord;StdCall;
  1360. var
  1361. AMessage: Msg;
  1362. begin
  1363. if not(winregistered) then
  1364. begin
  1365. if UseChildWindow then
  1366. begin
  1367. if not(WinRegisterWithChild) then
  1368. begin
  1369. MessageBox(0, 'Window registration failed', nil, mb_Ok);
  1370. ExitThread(1);
  1371. end;
  1372. end
  1373. else
  1374. begin
  1375. if not(WinRegister) then
  1376. begin
  1377. MessageBox(0, 'Window registration failed', nil, mb_Ok);
  1378. ExitThread(1);
  1379. end;
  1380. end;
  1381. GraphWindow:=WinCreate;
  1382. winregistered:=true;
  1383. end;
  1384. if longint(GraphWindow) = 0 then begin
  1385. MessageBox(0, 'Window creation failed', nil, mb_Ok);
  1386. ExitThread(1);
  1387. end;
  1388. while longint(GetMessage(@AMessage, 0, 0, 0))=longint(true) do
  1389. begin
  1390. TranslateMessage(AMessage);
  1391. DispatchMessage(AMessage);
  1392. end;
  1393. MessageHandleThread:=0;
  1394. end;
  1395. procedure InitWin32GUI16colors;
  1396. var
  1397. threadexitcode : longint;
  1398. begin
  1399. getmem(pal,sizeof(RGBrec)*maxcolor);
  1400. move(DefaultColors,pal^,sizeof(RGBrec)*maxcolor);
  1401. if (IntCurrentMode=mMaximizedWindow16) or
  1402. (IntCurrentMode=mMaximizedWindow256) or
  1403. (IntCurrentMode=mMaximizedWindow32k) or
  1404. (IntCurrentMode=mMaximizedWindow64k) or
  1405. (IntCurrentMode=mMaximizedWindow16M) then
  1406. extrastyle:=ws_maximize
  1407. else
  1408. extrastyle:=0;
  1409. { start graph subsystem }
  1410. InitializeCriticalSection(graphdrawing);
  1411. graphrunning:=false;
  1412. MessageThreadHandle:=CreateThread(nil,0,@MessageHandleThread,
  1413. nil,0,MessageThreadID);
  1414. repeat
  1415. GetExitCodeThread(MessageThreadHandle,@threadexitcode);
  1416. until graphrunning or (threadexitcode<>STILL_ACTIVE);
  1417. if threadexitcode<>STILL_ACTIVE then
  1418. _graphresult := grerror;
  1419. end;
  1420. procedure CloseGraph;
  1421. begin
  1422. If not isgraphmode then
  1423. begin
  1424. _graphresult := grnoinitgraph;
  1425. exit
  1426. end;
  1427. if UseChildWindow then
  1428. begin
  1429. { if the child window isn't destroyed }
  1430. { the main window can't be closed }
  1431. { I don't know any other way (FK) }
  1432. PostMessage(GraphWindow,wm_destroy,0,0);
  1433. PostMessage(ParentWindow,wm_destroy,0,0)
  1434. end
  1435. else
  1436. PostMessage(GraphWindow,wm_destroy,0,0);
  1437. PostThreadMessage(MessageThreadHandle,wm_quit,0,0);
  1438. WaitForSingleObject(MessageThreadHandle,Infinite);
  1439. CloseHandle(MessageThreadHandle);
  1440. DeleteCriticalSection(graphdrawing);
  1441. freemem(pal,sizeof(RGBrec)*maxcolor);
  1442. end;
  1443. procedure LineWin32GUI(X1, Y1, X2, Y2: smallint); {$ifndef fpc}far;{$endif fpc}
  1444. var X, Y : smallint;
  1445. deltax, deltay : smallint;
  1446. d, dinc1, dinc2: smallint;
  1447. xinc1 : smallint;
  1448. xinc2 : smallint;
  1449. yinc1 : smallint;
  1450. yinc2 : smallint;
  1451. i : smallint;
  1452. Flag : Boolean; { determines pixel direction in thick lines }
  1453. NumPixels : smallint;
  1454. PixelCount : smallint;
  1455. OldCurrentColor: Word;
  1456. swtmp : smallint;
  1457. TmpNumPixels : smallint;
  1458. col : longint;
  1459. pen,oldpen : hpen;
  1460. begin
  1461. if graphrunning then
  1462. begin
  1463. {******************************************}
  1464. { SOLID LINES }
  1465. {******************************************}
  1466. if lineinfo.LineStyle = SolidLn then
  1467. Begin
  1468. { Convert to global coordinates. }
  1469. x1 := x1 + StartXViewPort;
  1470. x2 := x2 + StartXViewPort;
  1471. y1 := y1 + StartYViewPort;
  1472. y2 := y2 + StartYViewPort;
  1473. { if fully clipped then exit... }
  1474. if ClipPixels then
  1475. begin
  1476. if LineClipped(x1,y1,x2,y2,StartXViewPort, StartYViewPort,
  1477. StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then
  1478. exit;
  1479. If LineInfo.Thickness=NormWidth then
  1480. Begin
  1481. EnterCriticalSection(graphdrawing);
  1482. {
  1483. if currentwritemode<>normalput then
  1484. begin
  1485. case currentwritemode of
  1486. XORPut:
  1487. begin
  1488. SetROP2(windc,R2_XORPEN);
  1489. SetROP2(bitmapdc,R2_XORPEN);
  1490. end;
  1491. AndPut:
  1492. begin
  1493. SetROP2(windc,R2_MASKPEN);
  1494. SetROP2(bitmapdc,R2_MASKPEN);
  1495. end;
  1496. OrPut:
  1497. begin
  1498. SetROP2(windc,R2_MERGEPEN);
  1499. SetROP2(bitmapdc,R2_MERGEPEN);
  1500. end;
  1501. end;
  1502. end;
  1503. }
  1504. col:=RGB(pal[CurrentColor].red,pal[CurrentColor].green,pal[CurrentColor].blue);
  1505. pen:=CreatePen(PS_SOLID,1,col);
  1506. if pen=0 then
  1507. writeln('Pen konnte nicht erzeugt werden!');
  1508. oldpen:=SelectObject(windc,pen);
  1509. MoveToEx(windc,x1,y1,nil);
  1510. Windows.LineTo(windc,x2,y2);
  1511. SetPixel(windc,x2,y2,col);
  1512. SelectObject(windc,oldpen);
  1513. oldpen:=SelectObject(bitmapdc,pen);
  1514. MoveToEx(bitmapdc,x1,y1,nil);
  1515. Windows.LineTo(bitmapdc,x2,y2);
  1516. SetPixel(bitmapdc,x2,y2,col);
  1517. SelectObject(bitmapdc,oldpen);
  1518. DeleteObject(pen);
  1519. {
  1520. if currentwritemode<>normalput then
  1521. begin
  1522. SetROP2(windc,R2_COPYPEN);
  1523. SetROP2(bitmapdc,R2_COPYPEN);
  1524. end;
  1525. }
  1526. LeaveCriticalSection(graphdrawing);
  1527. end
  1528. else
  1529. { Thick width lines }
  1530. begin
  1531. { Draw the pixels }
  1532. for i := 1 to numpixels do
  1533. begin
  1534. { all depending on the slope, we can determine }
  1535. { in what direction the extra width pixels will be put }
  1536. If Flag then
  1537. Begin
  1538. DirectPutPixelClip(x-1,y);
  1539. DirectPutPixelClip(x,y);
  1540. DirectPutPixelClip(x+1,y);
  1541. end
  1542. else
  1543. Begin
  1544. DirectPutPixelClip(x, y-1);
  1545. DirectPutPixelClip(x, y);
  1546. DirectPutPixelClip(x, y+1);
  1547. end;
  1548. if d < 0 then
  1549. begin
  1550. d := d + dinc1;
  1551. x := x + xinc1;
  1552. y := y + yinc1;
  1553. end
  1554. else
  1555. begin
  1556. d := d + dinc2;
  1557. x := x + xinc2;
  1558. y := y + yinc2;
  1559. end;
  1560. end;
  1561. end;
  1562. end;
  1563. end
  1564. else
  1565. {******************************************}
  1566. { begin patterned lines }
  1567. {******************************************}
  1568. Begin
  1569. { Convert to global coordinates. }
  1570. x1 := x1 + StartXViewPort;
  1571. x2 := x2 + StartXViewPort;
  1572. y1 := y1 + StartYViewPort;
  1573. y2 := y2 + StartYViewPort;
  1574. { if fully clipped then exit... }
  1575. if ClipPixels then
  1576. begin
  1577. if LineClipped(x1,y1,x2,y2,StartXViewPort, StartYViewPort,
  1578. StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then
  1579. exit;
  1580. end;
  1581. OldCurrentColor := CurrentColor;
  1582. PixelCount:=0;
  1583. if y1 = y2 then
  1584. Begin
  1585. { Check if we must swap }
  1586. if x1 >= x2 then
  1587. Begin
  1588. swtmp := x1;
  1589. x1 := x2;
  1590. x2 := swtmp;
  1591. end;
  1592. if LineInfo.Thickness = NormWidth then
  1593. Begin
  1594. for PixelCount:=x1 to x2 do
  1595. { optimization: PixelCount mod 16 }
  1596. if LinePatterns[PixelCount and 15] = TRUE then
  1597. begin
  1598. DirectPutPixel(PixelCount,y2);
  1599. end;
  1600. end
  1601. else
  1602. Begin
  1603. for i:=-1 to 1 do
  1604. Begin
  1605. for PixelCount:=x1 to x2 do
  1606. { Optimization from Thomas - mod 16 = and 15 }
  1607. {this optimization has been performed by the compiler
  1608. for while as well (JM)}
  1609. if LinePatterns[PixelCount and 15] = TRUE then
  1610. begin
  1611. DirectPutPixelClip(PixelCount,y2+i);
  1612. end;
  1613. end;
  1614. end;
  1615. end
  1616. else
  1617. if x1 = x2 then
  1618. Begin
  1619. { Check if we must swap }
  1620. if y1 >= y2 then
  1621. Begin
  1622. swtmp := y1;
  1623. y1 := y2;
  1624. y2 := swtmp;
  1625. end;
  1626. if LineInfo.Thickness = NormWidth then
  1627. Begin
  1628. for PixelCount:=y1 to y2 do
  1629. { compare if we should plot a pixel here , compare }
  1630. { with predefined line patterns... }
  1631. if LinePatterns[PixelCount and 15] = TRUE then
  1632. begin
  1633. DirectPutPixel(x1,PixelCount);
  1634. end;
  1635. end
  1636. else
  1637. Begin
  1638. for i:=-1 to 1 do
  1639. Begin
  1640. for PixelCount:=y1 to y2 do
  1641. { compare if we should plot a pixel here , compare }
  1642. { with predefined line patterns... }
  1643. if LinePatterns[PixelCount and 15] = TRUE then
  1644. begin
  1645. DirectPutPixelClip(x1+i,PixelCount);
  1646. end;
  1647. end;
  1648. end;
  1649. end
  1650. else
  1651. Begin
  1652. oldCurrentColor := CurrentColor;
  1653. { Calculate deltax and deltay for initialisation }
  1654. deltax := abs(x2 - x1);
  1655. deltay := abs(y2 - y1);
  1656. { Initialize all vars based on which is the independent variable }
  1657. if deltax >= deltay then
  1658. begin
  1659. Flag := FALSE;
  1660. { x is independent variable }
  1661. numpixels := deltax + 1;
  1662. d := (2 * deltay) - deltax;
  1663. dinc1 := deltay Shl 1;
  1664. dinc2 := (deltay - deltax) shl 1;
  1665. xinc1 := 1;
  1666. xinc2 := 1;
  1667. yinc1 := 0;
  1668. yinc2 := 1;
  1669. end
  1670. else
  1671. begin
  1672. Flag := TRUE;
  1673. { y is independent variable }
  1674. numpixels := deltay + 1;
  1675. d := (2 * deltax) - deltay;
  1676. dinc1 := deltax Shl 1;
  1677. dinc2 := (deltax - deltay) shl 1;
  1678. xinc1 := 0;
  1679. xinc2 := 1;
  1680. yinc1 := 1;
  1681. yinc2 := 1;
  1682. end;
  1683. { Make sure x and y move in the right directions }
  1684. if x1 > x2 then
  1685. begin
  1686. xinc1 := - xinc1;
  1687. xinc2 := - xinc2;
  1688. end;
  1689. if y1 > y2 then
  1690. begin
  1691. yinc1 := - yinc1;
  1692. yinc2 := - yinc2;
  1693. end;
  1694. { Start drawing at <x1, y1> }
  1695. x := x1;
  1696. y := y1;
  1697. If LineInfo.Thickness=ThickWidth then
  1698. Begin
  1699. TmpNumPixels := NumPixels-1;
  1700. { Draw the pixels }
  1701. for i := 0 to TmpNumPixels do
  1702. begin
  1703. { all depending on the slope, we can determine }
  1704. { in what direction the extra width pixels will be put }
  1705. If Flag then
  1706. Begin
  1707. { compare if we should plot a pixel here , compare }
  1708. { with predefined line patterns... }
  1709. if LinePatterns[i and 15] = TRUE then
  1710. begin
  1711. DirectPutPixelClip(x-1,y);
  1712. DirectPutPixelClip(x,y);
  1713. DirectPutPixelClip(x+1,y);
  1714. end;
  1715. end
  1716. else
  1717. Begin
  1718. { compare if we should plot a pixel here , compare }
  1719. { with predefined line patterns... }
  1720. if LinePatterns[i and 15] = TRUE then
  1721. begin
  1722. DirectPutPixelClip(x,y-1);
  1723. DirectPutPixelClip(x,y);
  1724. DirectPutPixelClip(x,y+1);
  1725. end;
  1726. end;
  1727. if d < 0 then
  1728. begin
  1729. d := d + dinc1;
  1730. x := x + xinc1;
  1731. y := y + yinc1;
  1732. end
  1733. else
  1734. begin
  1735. d := d + dinc2;
  1736. x := x + xinc2;
  1737. y := y + yinc2;
  1738. end;
  1739. end;
  1740. end
  1741. else
  1742. Begin
  1743. { instead of putting in loop , substract by one now }
  1744. TmpNumPixels := NumPixels-1;
  1745. { NormWidth }
  1746. for i := 0 to TmpNumPixels do
  1747. begin
  1748. if LinePatterns[i and 15] = TRUE then
  1749. begin
  1750. DirectPutPixel(x,y);
  1751. end;
  1752. if d < 0 then
  1753. begin
  1754. d := d + dinc1;
  1755. x := x + xinc1;
  1756. y := y + yinc1;
  1757. end
  1758. else
  1759. begin
  1760. d := d + dinc2;
  1761. x := x + xinc2;
  1762. y := y + yinc2;
  1763. end;
  1764. end;
  1765. end
  1766. end;
  1767. {******************************************}
  1768. { end patterned lines }
  1769. {******************************************}
  1770. { restore color }
  1771. CurrentColor:=OldCurrentColor;
  1772. end;
  1773. end;
  1774. end; { Line }
  1775. { multipage support could be done by using more than one background bitmap }
  1776. procedure SetVisualWin32GUI(page: word);
  1777. begin
  1778. end;
  1779. procedure SetActiveWin32GUI(page: word);
  1780. begin
  1781. end;
  1782. function queryadapterinfo : pmodeinfo;
  1783. var
  1784. mode: TModeInfo;
  1785. ScreenWidth,ScreenHeight : longint;
  1786. ScreenWidthMaximized,ScreenHeightMaximized : longint;
  1787. procedure SetupWin32GUIDefault;
  1788. begin
  1789. mode.DirectPutPixel:={$ifdef fpc}@{$endif}DirectPutPixel16Win32GUI;
  1790. mode.PutPixel:={$ifdef fpc}@{$endif}PutPixel16Win32GUI;
  1791. mode.GetPixel:={$ifdef fpc}@{$endif}GetPixel16Win32GUI;
  1792. mode.HLine := {$ifdef fpc}@{$endif}HLine16Win32GUI;
  1793. mode.SetRGBPalette := {$ifdef fpc}@{$endif}SetRGBPaletteWin32GUI;
  1794. mode.GetRGBPalette := {$ifdef fpc}@{$endif}GetRGBPaletteWin32GUI;
  1795. mode.SetVisualPage := {$ifdef fpc}@{$endif}SetVisualWin32GUI;
  1796. mode.SetActivePage := {$ifdef fpc}@{$endif}SetActiveWin32GUI;
  1797. mode.InitMode := {$ifdef fpc}@{$endif}InitWin32GUI16colors;
  1798. mode.OuttextXY:={$ifdef fpc}@{$endif}OuttextXYWin32GUI;
  1799. mode.VLine := {$ifdef fpc}@{$endif}VLine16Win32GUI;
  1800. // mode.circle := {$ifdef fpc}@{$endif}Circle16Win32GUI;
  1801. // doesn't work yet
  1802. // mode.Line:={$ifdef fpc}@{$endif}LineWin32GUI;
  1803. end;
  1804. begin
  1805. SaveVideoState:={$ifdef fpc}@{$endif}savestate;
  1806. RestoreVideoState:={$ifdef fpc}@{$endif}restorestate;
  1807. { we must take care of the border and caption }
  1808. ScreenWidth:=GetSystemMetrics(SM_CXSCREEN)-
  1809. 2*GetSystemMetrics(SM_CXFRAME);
  1810. ScreenHeight:=GetSystemMetrics(SM_CYSCREEN)-
  1811. 2*GetSystemMetrics(SM_CYFRAME)-
  1812. GetSystemMetrics(SM_CYCAPTION);
  1813. { for maximozed windows it's again different }
  1814. { here we've only a caption }
  1815. ScreenWidthMaximized:=GetSystemMetrics(SM_CXFULLSCREEN);
  1816. { neither GetSystemMetrics(SM_CYFULLSCREEN nor }
  1817. { SystemParametersInfo(SPI_GETWORKAREA) }
  1818. { takes a hidden try into account :( FK }
  1819. ScreenHeightMaximized:=GetSystemMetrics(SM_CYFULLSCREEN);
  1820. QueryAdapterInfo := ModeList;
  1821. { If the mode listing already exists... }
  1822. { simply return it, without changing }
  1823. { anything... }
  1824. if assigned(ModeList) then
  1825. exit;
  1826. { the first one becomes the standard mode }
  1827. if (ScreenWidth>=640) and (ScreenHeight>=480) then
  1828. begin
  1829. InitMode(mode);
  1830. mode.DriverNumber:= VGA;
  1831. mode.HardwarePages:= 0;
  1832. mode.ModeNumber:=VGAHi;
  1833. mode.ModeName:='640 x 480 x 16 Win32GUI';
  1834. mode.MaxColor := 16;
  1835. mode.PaletteSize := mode.MaxColor;
  1836. mode.DirectColor := FALSE;
  1837. mode.MaxX := 639;
  1838. mode.MaxY := 479;
  1839. SetupWin32GUIDefault;
  1840. mode.XAspect := 10000;
  1841. mode.YAspect := 10000;
  1842. AddMode(mode);
  1843. end;
  1844. if (ScreenWidth>=640) and (ScreenHeight>=200) then
  1845. begin
  1846. InitMode(mode);
  1847. { now add all standard VGA modes... }
  1848. mode.DriverNumber:= VGA;
  1849. mode.HardwarePages:= 0;
  1850. mode.ModeNumber:=VGALo;
  1851. mode.ModeName:='640 x 200 x 16 Win32GUI';
  1852. mode.MaxColor := 16;
  1853. mode.PaletteSize := mode.MaxColor;
  1854. mode.DirectColor := FALSE;
  1855. mode.MaxX := 639;
  1856. mode.MaxY := 199;
  1857. SetupWin32GUIDefault;
  1858. mode.XAspect := 10000;
  1859. mode.YAspect := 10000;
  1860. AddMode(mode);
  1861. end;
  1862. if (ScreenWidth>=640) and (ScreenHeight>=350) then
  1863. begin
  1864. InitMode(mode);
  1865. mode.DriverNumber:= VGA;
  1866. mode.HardwarePages:= 0;
  1867. mode.ModeNumber:=VGAMed;
  1868. mode.ModeName:='640 x 350 x 16 Win32GUI';
  1869. mode.MaxColor := 16;
  1870. mode.PaletteSize := mode.MaxColor;
  1871. mode.DirectColor := FALSE;
  1872. mode.MaxX := 639;
  1873. mode.MaxY := 349;
  1874. SetupWin32GUIDefault;
  1875. mode.XAspect := 10000;
  1876. mode.YAspect := 10000;
  1877. AddMode(mode);
  1878. end;
  1879. if (ScreenWidth>=640) and (ScreenHeight>=400) then
  1880. begin
  1881. InitMode(mode);
  1882. mode.DriverNumber:= VESA;
  1883. mode.HardwarePages:= 0;
  1884. mode.ModeNumber:=m640x400x256;
  1885. mode.ModeName:='640 x 400 x 256 Win32GUI';
  1886. mode.MaxColor := 256;
  1887. mode.PaletteSize := mode.MaxColor;
  1888. mode.DirectColor := FALSE;
  1889. mode.MaxX := 639;
  1890. mode.MaxY := 399;
  1891. SetupWin32GUIDefault;
  1892. mode.XAspect := 10000;
  1893. mode.YAspect := 10000;
  1894. AddMode(mode);
  1895. end;
  1896. if (ScreenWidth>=640) and (ScreenHeight>=480) then
  1897. begin
  1898. InitMode(mode);
  1899. mode.DriverNumber:= VESA;
  1900. mode.HardwarePages:= 0;
  1901. mode.ModeNumber:=m640x480x256;
  1902. mode.ModeName:='640 x 480 x 256 Win32GUI';
  1903. mode.MaxColor := 256;
  1904. mode.PaletteSize := mode.MaxColor;
  1905. mode.DirectColor := FALSE;
  1906. mode.MaxX := 639;
  1907. mode.MaxY := 479;
  1908. SetupWin32GUIDefault;
  1909. mode.XAspect := 10000;
  1910. mode.YAspect := 10000;
  1911. AddMode(mode);
  1912. end;
  1913. { add 800x600 only if screen is large enough }
  1914. If (ScreenWidth>=800) and (ScreenHeight>=600) then
  1915. begin
  1916. InitMode(mode);
  1917. mode.DriverNumber:= VESA;
  1918. mode.HardwarePages:= 0;
  1919. mode.ModeNumber:=m800x600x16;
  1920. mode.ModeName:='800 x 600 x 16 Win32GUI';
  1921. mode.MaxColor := 16;
  1922. mode.PaletteSize := mode.MaxColor;
  1923. mode.DirectColor := FALSE;
  1924. mode.MaxX := 799;
  1925. mode.MaxY := 599;
  1926. SetupWin32GUIDefault;
  1927. mode.XAspect := 10000;
  1928. mode.YAspect := 10000;
  1929. AddMode(mode);
  1930. InitMode(mode);
  1931. mode.DriverNumber:= VESA;
  1932. mode.HardwarePages:= 0;
  1933. mode.ModeNumber:=m800x600x256;
  1934. mode.ModeName:='800 x 600 x 256 Win32GUI';
  1935. mode.MaxColor := 256;
  1936. mode.PaletteSize := mode.MaxColor;
  1937. mode.DirectColor := FALSE;
  1938. mode.MaxX := 799;
  1939. mode.MaxY := 599;
  1940. SetupWin32GUIDefault;
  1941. mode.XAspect := 10000;
  1942. mode.YAspect := 10000;
  1943. AddMode(mode);
  1944. end;
  1945. { add 1024x768 only if screen is large enough }
  1946. If (ScreenWidth>=1024) and (ScreenHeight>=768) then
  1947. begin
  1948. InitMode(mode);
  1949. mode.DriverNumber:= VESA;
  1950. mode.HardwarePages:= 0;
  1951. mode.ModeNumber:=m1024x768x16;
  1952. mode.ModeName:='1024 x 768 x 16 Win32GUI';
  1953. mode.MaxColor := 16;
  1954. mode.PaletteSize := mode.MaxColor;
  1955. mode.DirectColor := FALSE;
  1956. mode.MaxX := 1023;
  1957. mode.MaxY := 767;
  1958. SetupWin32GUIDefault;
  1959. mode.XAspect := 10000;
  1960. mode.YAspect := 10000;
  1961. AddMode(mode);
  1962. InitMode(mode);
  1963. mode.DriverNumber:= VESA;
  1964. mode.HardwarePages:= 0;
  1965. mode.ModeNumber:=m1024x768x256;
  1966. mode.ModeName:='1024 x 768 x 256 Win32GUI';
  1967. mode.MaxColor := 256;
  1968. mode.PaletteSize := mode.MaxColor;
  1969. mode.DirectColor := FALSE;
  1970. mode.MaxX := 1023;
  1971. mode.MaxY := 768;
  1972. SetupWin32GUIDefault;
  1973. mode.XAspect := 10000;
  1974. mode.YAspect := 10000;
  1975. AddMode(mode);
  1976. end;
  1977. { add 1280x1024 only if screen is large enough }
  1978. If (ScreenWidth>=1280) and (ScreenHeight>=1024) then
  1979. begin
  1980. InitMode(mode);
  1981. mode.DriverNumber:= VESA;
  1982. mode.HardwarePages:= 0;
  1983. mode.ModeNumber:=m1280x1024x16;
  1984. mode.ModeName:='1280 x 1024 x 16 Win32GUI';
  1985. mode.MaxColor := 16;
  1986. mode.PaletteSize := mode.MaxColor;
  1987. mode.DirectColor := FALSE;
  1988. mode.MaxX := 1279;
  1989. mode.MaxY := 1023;
  1990. SetupWin32GUIDefault;
  1991. mode.XAspect := 10000;
  1992. mode.YAspect := 10000;
  1993. AddMode(mode);
  1994. InitMode(mode);
  1995. mode.DriverNumber:= VESA;
  1996. mode.HardwarePages:= 0;
  1997. mode.ModeNumber:=m1280x1024x256;
  1998. mode.ModeName:='1280 x 1024 x 256 Win32GUI';
  1999. mode.MaxColor := 256;
  2000. mode.PaletteSize := mode.MaxColor;
  2001. mode.DirectColor := FALSE;
  2002. mode.MaxX := 1279;
  2003. mode.MaxY := 1023;
  2004. SetupWin32GUIDefault;
  2005. mode.XAspect := 10000;
  2006. mode.YAspect := 10000;
  2007. AddMode(mode);
  2008. end;
  2009. { at least we add a mode with the largest possible window }
  2010. InitMode(mode);
  2011. mode.DriverNumber:= VESA;
  2012. mode.HardwarePages:= 0;
  2013. mode.ModeNumber:=mLargestWindow16;
  2014. mode.ModeName:='Largest Window x 16';
  2015. mode.MaxColor := 16;
  2016. mode.PaletteSize := mode.MaxColor;
  2017. mode.DirectColor := FALSE;
  2018. mode.MaxX := ScreenWidth-1;
  2019. mode.MaxY := ScreenHeight-1;
  2020. SetupWin32GUIDefault;
  2021. mode.XAspect := 10000;
  2022. mode.YAspect := 10000;
  2023. AddMode(mode);
  2024. InitMode(mode);
  2025. mode.DriverNumber:= VESA;
  2026. mode.HardwarePages:= 0;
  2027. mode.ModeNumber:=mLargestWindow256;
  2028. mode.ModeName:='Largest Window x 256';
  2029. mode.MaxColor := 256;
  2030. mode.PaletteSize := mode.MaxColor;
  2031. mode.DirectColor := FALSE;
  2032. mode.MaxX := ScreenWidth-1;
  2033. mode.MaxY := ScreenHeight-1;
  2034. SetupWin32GUIDefault;
  2035. mode.XAspect := 10000;
  2036. mode.YAspect := 10000;
  2037. AddMode(mode);
  2038. { .. and a maximized window }
  2039. InitMode(mode);
  2040. mode.DriverNumber:= VESA;
  2041. mode.HardwarePages:= 0;
  2042. mode.ModeNumber:=mMaximizedWindow16;
  2043. mode.ModeName:='Maximized Window x 16';
  2044. mode.MaxColor := 16;
  2045. mode.PaletteSize := mode.MaxColor;
  2046. mode.DirectColor := FALSE;
  2047. mode.MaxX := ScreenWidthMaximized-1;
  2048. mode.MaxY := ScreenHeightMaximized-1;
  2049. SetupWin32GUIDefault;
  2050. mode.XAspect := 10000;
  2051. mode.YAspect := 10000;
  2052. AddMode(mode);
  2053. InitMode(mode);
  2054. mode.DriverNumber:= VESA;
  2055. mode.HardwarePages:= 0;
  2056. mode.ModeNumber:=mMaximizedWindow256;
  2057. mode.ModeName:='Maximized Window x 256';
  2058. mode.MaxColor := 256;
  2059. mode.PaletteSize := mode.MaxColor;
  2060. mode.DirectColor := FALSE;
  2061. mode.MaxX := ScreenWidthMaximized-1;
  2062. mode.MaxY := ScreenHeightMaximized-1;
  2063. SetupWin32GUIDefault;
  2064. mode.XAspect := 10000;
  2065. mode.YAspect := 10000;
  2066. AddMode(mode);
  2067. end;
  2068. begin
  2069. InitializeGraph;
  2070. charmessagehandler:=nil;
  2071. mousemessagehandler:=nil;
  2072. commandmessagehandler:=nil;
  2073. notifymessagehandler:=nil;
  2074. OnGraphWindowCreation:=nil;
  2075. end.
  2076. {
  2077. $Log$
  2078. Revision 1.6 2001-04-16 10:57:05 peter
  2079. * stricter compiler fixes
  2080. Revision 1.5 2000/12/19 11:59:12 michael
  2081. * Fixes from Peter
  2082. Revision 1.4 2000/11/14 19:45:08 florian
  2083. * child window destruction fixed
  2084. Revision 1.3 2000/10/21 18:20:17 florian
  2085. * a lot of small changes:
  2086. - setlength is internal
  2087. - win32 graph unit extended
  2088. ....
  2089. Revision 1.2 2000/07/13 11:33:57 michael
  2090. + removed logs
  2091. }