graph.pp 76 KB

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