graph.pp 76 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239
  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. if (colorNum>=0) and (colorNum<=high(pens)) and (pens[colorNum]<>0) then
  1045. begin
  1046. DeleteObject(pens[colorNum]);
  1047. pens[colorNum]:=0;
  1048. end;
  1049. end;
  1050. procedure GetRGBPaletteWin32GUI(colorNum : integer;
  1051. var redValue,greenvalue,bluevalue : integer);
  1052. begin
  1053. if directcolor or (colornum<0) or (colornum>=maxcolor) then
  1054. begin
  1055. _graphresult:=grerror;
  1056. exit;
  1057. end;
  1058. redValue:=pal[colorNum].red;
  1059. greenValue:=pal[colorNum].green;
  1060. blueValue:=pal[colorNum].blue;
  1061. end;
  1062. procedure savestate;
  1063. begin
  1064. end;
  1065. procedure restorestate;
  1066. begin
  1067. end;
  1068. function WindowProcGraph(Window: HWnd; AMessage, WParam,
  1069. LParam: Longint): Longint; stdcall; export;
  1070. var
  1071. dc : hdc;
  1072. ps : paintstruct;
  1073. r : rect;
  1074. oldbrush : hbrush;
  1075. oldpen : hpen;
  1076. i : longint;
  1077. begin
  1078. WindowProcGraph := 0;
  1079. case AMessage of
  1080. wm_lbuttondown,
  1081. wm_rbuttondown,
  1082. wm_mbuttondown,
  1083. wm_lbuttonup,
  1084. wm_rbuttonup,
  1085. wm_mbuttonup,
  1086. wm_lbuttondblclk,
  1087. wm_rbuttondblclk,
  1088. wm_mbuttondblclk:
  1089. {
  1090. This leads to problem, i.e. the menu etc doesn't work any longer
  1091. wm_nclbuttondown,
  1092. wm_ncrbuttondown,
  1093. wm_ncmbuttondown,
  1094. wm_nclbuttonup,
  1095. wm_ncrbuttonup,
  1096. wm_ncmbuttonup,
  1097. wm_nclbuttondblclk,
  1098. wm_ncrbuttondblclk,
  1099. wm_ncmbuttondblclk:
  1100. }
  1101. begin
  1102. if assigned(mousemessagehandler) then
  1103. WindowProcGraph:=mousemessagehandler(window,amessage,wparam,lparam);
  1104. end;
  1105. wm_notify:
  1106. begin
  1107. if assigned(notifymessagehandler) then
  1108. WindowProcGraph:=notifymessagehandler(window,amessage,wparam,lparam);
  1109. end;
  1110. wm_command:
  1111. if assigned(commandmessagehandler) then
  1112. WindowProcGraph:=commandmessagehandler(window,amessage,wparam,lparam);
  1113. wm_keydown,
  1114. wm_keyup,
  1115. wm_char:
  1116. begin
  1117. if assigned(charmessagehandler) then
  1118. WindowProcGraph:=charmessagehandler(window,amessage,wparam,lparam);
  1119. end;
  1120. wm_paint:
  1121. begin
  1122. {$ifdef DEBUG_WM_PAINT}
  1123. inc(wm_paint_count);
  1124. {$endif DEBUG_WM_PAINT}
  1125. {$ifdef DEBUGCHILDS}
  1126. writeln('Start child painting');
  1127. {$endif DEBUGCHILDS}
  1128. if not GetUpdateRect(Window,@r,false) then
  1129. exit;
  1130. EnterCriticalSection(graphdrawing);
  1131. graphrunning:=true;
  1132. dc:=BeginPaint(Window,@ps);
  1133. {$ifdef DEBUG_WM_PAINT}
  1134. Writeln(graphdebug,'WM_PAINT in ((',r.left,',',r.top,
  1135. '),(',r.right,',',r.bottom,'))');
  1136. {$endif def DEBUG_WM_PAINT}
  1137. if graphrunning then
  1138. {BitBlt(dc,0,0,maxx+1,maxy+1,bitmapdc,0,0,SRCCOPY);}
  1139. BitBlt(dc,r.left,r.top,r.right-r.left+1,r.bottom-r.top+1,bitmapdc,r.left,r.top,SRCCOPY);
  1140. EndPaint(Window,ps);
  1141. LeaveCriticalSection(graphdrawing);
  1142. Exit;
  1143. end;
  1144. wm_create:
  1145. begin
  1146. {$ifdef DEBUG_WM_PAINT}
  1147. assign(graphdebug,'wingraph.log');
  1148. rewrite(graphdebug);
  1149. {$endif DEBUG_WM_PAINT}
  1150. {$ifdef DEBUGCHILDS}
  1151. writeln('Creating window (HWND: ',window,')... ');
  1152. {$endif DEBUGCHILDS}
  1153. GraphWindow:=window;
  1154. EnterCriticalSection(graphdrawing);
  1155. dc:=GetDC(window);
  1156. {$ifdef DEBUGCHILDS}
  1157. writeln('Window DC: ',dc);
  1158. {$endif DEBUGCHILDS}
  1159. bitmapdc:=CreateCompatibleDC(dc);
  1160. savedscreen:=CreateCompatibleBitmap(dc,maxx+1,maxy+1);
  1161. ReleaseDC(window,dc);
  1162. oldbitmap:=SelectObject(bitmapdc,savedscreen);
  1163. windc:=GetDC(window);
  1164. // clear everything
  1165. oldpen:=SelectObject(bitmapdc,GetStockObject(BLACK_PEN));
  1166. oldbrush:=SelectObject(bitmapdc,GetStockObject(BLACK_BRUSH));
  1167. Windows.Rectangle(bitmapdc,0,0,maxx,maxy);
  1168. SelectObject(bitmapdc,oldpen);
  1169. SelectObject(bitmapdc,oldbrush);
  1170. // ... the window too
  1171. oldpen:=SelectObject(windc,GetStockObject(BLACK_PEN));
  1172. oldbrush:=SelectObject(windc,GetStockObject(BLACK_BRUSH));
  1173. Windows.Rectangle(windc,0,0,maxx,maxy);
  1174. SelectObject(windc,oldpen);
  1175. SelectObject(windc,oldbrush);
  1176. // clear font cache
  1177. fillchar(bitmapfonthorizoncache,sizeof(bitmapfonthorizoncache),0);
  1178. fillchar(bitmapfontverticalcache,sizeof(bitmapfontverticalcache),0);
  1179. // clear predefined pens
  1180. fillchar(pens,sizeof(pens),0);
  1181. if assigned(OnGraphWindowCreation) then
  1182. OnGraphWindowCreation;
  1183. LeaveCriticalSection(graphdrawing);
  1184. {$ifdef DEBUGCHILDS}
  1185. writeln('done');
  1186. GetClientRect(window,@r);
  1187. writeln('Window size: ',r.right,',',r.bottom);
  1188. {$endif DEBUGCHILDS}
  1189. end;
  1190. wm_Destroy:
  1191. begin
  1192. EnterCriticalSection(graphdrawing);
  1193. graphrunning:=false;
  1194. ReleaseDC(GraphWindow,windc);
  1195. SelectObject(bitmapdc,oldbitmap);
  1196. DeleteObject(savedscreen);
  1197. DeleteDC(bitmapdc);
  1198. // release font cache
  1199. for i:=0 to 255 do
  1200. if bitmapfonthorizoncache[i]<>0 then
  1201. DeleteObject(bitmapfonthorizoncache[i]);
  1202. for i:=0 to 255 do
  1203. if bitmapfontverticalcache[i]<>0 then
  1204. DeleteObject(bitmapfontverticalcache[i]);
  1205. for i:=0 to high(pens) do
  1206. if pens[i]<>0 then
  1207. DeleteObject(pens[i]);
  1208. LeaveCriticalSection(graphdrawing);
  1209. {$ifdef DEBUG_WM_PAINT}
  1210. close(graphdebug);
  1211. {$endif DEBUG_WM_PAINT}
  1212. PostQuitMessage(0);
  1213. Exit;
  1214. end
  1215. else
  1216. WindowProcGraph := DefWindowProc(Window, AMessage, WParam, LParam);
  1217. end;
  1218. end;
  1219. function WindowProcParent(Window: HWnd; AMessage, WParam,
  1220. LParam: Longint): Longint; stdcall; export;
  1221. begin
  1222. WindowProcParent := 0;
  1223. case AMessage of
  1224. wm_keydown,
  1225. wm_keyup,
  1226. wm_char:
  1227. begin
  1228. if assigned(charmessagehandler) then
  1229. WindowProcParent:=charmessagehandler(window,amessage,wparam,lparam);
  1230. end;
  1231. wm_notify:
  1232. begin
  1233. if assigned(notifymessagehandler) then
  1234. WindowProcParent:=notifymessagehandler(window,amessage,wparam,lparam);
  1235. end;
  1236. wm_command:
  1237. if assigned(commandmessagehandler) then
  1238. WindowProcParent:=commandmessagehandler(window,amessage,wparam,lparam);
  1239. else
  1240. WindowProcParent := DefWindowProc(Window, AMessage, WParam, LParam);
  1241. end;
  1242. end;
  1243. function WinRegister: Boolean;
  1244. var
  1245. WindowClass: WndClass;
  1246. begin
  1247. WindowClass.Style := graphwindowstyle;
  1248. WindowClass.lpfnWndProc := WndProc(@WindowProcGraph);
  1249. WindowClass.cbClsExtra := 0;
  1250. WindowClass.cbWndExtra := 0;
  1251. WindowClass.hInstance := system.MainInstance;
  1252. if icon<>0 then
  1253. WindowClass.hIcon := icon
  1254. else
  1255. WindowClass.hIcon := LoadIcon(0, idi_Application);
  1256. WindowClass.hCursor := LoadCursor(0, idc_Arrow);
  1257. WindowClass.hbrBackground := GetStockObject(BLACK_BRUSH);
  1258. if menu<>0 then
  1259. WindowClass.lpszMenuName := MAKEINTRESOURCE(menu)
  1260. else
  1261. WindowClass.lpszMenuName := nil;
  1262. WindowClass.lpszClassName := 'FPCGraphWindow';
  1263. winregister:=RegisterClass(WindowClass) <> 0;
  1264. end;
  1265. function WinRegisterWithChild: Boolean;
  1266. var
  1267. WindowClass: WndClass;
  1268. begin
  1269. WindowClass.Style := graphwindowstyle;
  1270. WindowClass.lpfnWndProc := WndProc(@WindowProcParent);
  1271. WindowClass.cbClsExtra := 0;
  1272. WindowClass.cbWndExtra := 0;
  1273. WindowClass.hInstance := system.MainInstance;
  1274. if icon<>0 then
  1275. WindowClass.hIcon := icon
  1276. else
  1277. WindowClass.hIcon := LoadIcon(0, idi_Application);
  1278. WindowClass.hCursor := LoadCursor(0, idc_Arrow);
  1279. WindowClass.hbrBackground := GetStockObject(BLACK_BRUSH);
  1280. if menu<>0 then
  1281. WindowClass.lpszMenuName := MAKEINTRESOURCE(menu)
  1282. else
  1283. WindowClass.lpszMenuName := nil;
  1284. WindowClass.lpszClassName := 'FPCGraphWindowMain';
  1285. WinRegisterWithChild:=RegisterClass(WindowClass) <> 0;
  1286. {$ifdef DEBUGCHILDS}
  1287. writeln('Main window successfully registered: WinRegisterWithChild is ',WinRegisterWithChild);
  1288. {$endif DEBUGCHILDS}
  1289. if WinRegisterWithChild then
  1290. begin
  1291. WindowClass.Style := CS_HREDRAW or CS_VREDRAW;
  1292. WindowClass.lpfnWndProc := WndProc(@WindowProcGraph);
  1293. WindowClass.cbClsExtra := 0;
  1294. WindowClass.cbWndExtra := 0;
  1295. WindowClass.hInstance := system.MainInstance;
  1296. WindowClass.hIcon := 0;
  1297. WindowClass.hCursor := LoadCursor(0, idc_Arrow);
  1298. WindowClass.hbrBackground := GetStockObject(BLACK_BRUSH);
  1299. WindowClass.lpszMenuName := nil;
  1300. WindowClass.lpszClassName := 'FPCGraphWindowChild';
  1301. WinRegisterWithChild:=RegisterClass(WindowClass)<>0;
  1302. {$ifdef DEBUGCHILDS}
  1303. writeln('Child window registered: WinRegisterWithChild is ',WinRegisterWithChild);
  1304. {$endif DEBUGCHILDS}
  1305. end;
  1306. end;
  1307. var
  1308. // here we can force the creation of a maximized window }
  1309. extrastyle : cardinal;
  1310. { Create the Window Class }
  1311. function WinCreate : HWnd;
  1312. var
  1313. hWindow: HWnd;
  1314. begin
  1315. WinCreate:=0;
  1316. if UseChildWindow then
  1317. begin
  1318. ParentWindow:=CreateWindow('FPCGraphWindowMain', windowtitle,
  1319. WS_OVERLAPPEDWINDOW or WS_CLIPCHILDREN or extrastyle, longint(CW_USEDEFAULT), 0,
  1320. maxx+ChildOffset.Left+ChildOffset.Right+1+
  1321. 2*GetSystemMetrics(SM_CXFRAME),
  1322. maxy+ChildOffset.Top+ChildOffset.Bottom+1+
  1323. 2*GetSystemMetrics(SM_CYFRAME)+
  1324. GetSystemMetrics(SM_CYCAPTION),
  1325. 0, 0, system.MainInstance, nil);
  1326. if ParentWindow<>0 then
  1327. begin
  1328. ShowWindow(ParentWindow, SW_SHOW);
  1329. UpdateWindow(ParentWindow);
  1330. end
  1331. else
  1332. exit;
  1333. hWindow:=CreateWindow('FPCGraphWindowChild',nil,
  1334. WS_CHILD, ChildOffset.Left,ChildOffset.Top,
  1335. maxx+1,maxy+1,
  1336. ParentWindow, 0, system.MainInstance, nil);
  1337. if hwindow<>0 then
  1338. begin
  1339. ShowWindow(hwindow, SW_SHOW);
  1340. UpdateWindow(hwindow);
  1341. end
  1342. else
  1343. exit;
  1344. WinCreate:=hWindow;
  1345. end
  1346. else
  1347. begin
  1348. hWindow:=CreateWindow('FPCGraphWindow', windowtitle,
  1349. ws_OverlappedWindow or extrastyle, longint(CW_USEDEFAULT), 0,
  1350. maxx+1+2*GetSystemMetrics(SM_CXFRAME),
  1351. maxy+1+2*GetSystemMetrics(SM_CYFRAME)+
  1352. GetSystemMetrics(SM_CYCAPTION),
  1353. 0, 0, system.MainInstance, nil);
  1354. if hWindow <> 0 then
  1355. begin
  1356. ShowWindow(hWindow, SW_SHOW);
  1357. UpdateWindow(hWindow);
  1358. WinCreate:=hWindow;
  1359. end;
  1360. end;
  1361. end;
  1362. const
  1363. winregistered : boolean = false;
  1364. function MessageHandleThread(p : pointer) : DWord;StdCall;
  1365. var
  1366. AMessage: Msg;
  1367. begin
  1368. if not(winregistered) then
  1369. begin
  1370. if UseChildWindow then
  1371. begin
  1372. if not(WinRegisterWithChild) then
  1373. begin
  1374. MessageBox(0, 'Window registration failed', nil, mb_Ok);
  1375. ExitThread(1);
  1376. end;
  1377. end
  1378. else
  1379. begin
  1380. if not(WinRegister) then
  1381. begin
  1382. MessageBox(0, 'Window registration failed', nil, mb_Ok);
  1383. ExitThread(1);
  1384. end;
  1385. end;
  1386. GraphWindow:=WinCreate;
  1387. winregistered:=true;
  1388. end;
  1389. if longint(GraphWindow) = 0 then begin
  1390. MessageBox(0, 'Window creation failed', nil, mb_Ok);
  1391. ExitThread(1);
  1392. end;
  1393. while longint(GetMessage(@AMessage, 0, 0, 0))=longint(true) do
  1394. begin
  1395. TranslateMessage(AMessage);
  1396. DispatchMessage(AMessage);
  1397. end;
  1398. MessageHandleThread:=0;
  1399. end;
  1400. procedure InitWin32GUI16colors;
  1401. var
  1402. threadexitcode : longint;
  1403. begin
  1404. getmem(pal,sizeof(RGBrec)*maxcolor);
  1405. move(DefaultColors,pal^,sizeof(RGBrec)*maxcolor);
  1406. if (IntCurrentMode=mMaximizedWindow16) or
  1407. (IntCurrentMode=mMaximizedWindow256) or
  1408. (IntCurrentMode=mMaximizedWindow32k) or
  1409. (IntCurrentMode=mMaximizedWindow64k) or
  1410. (IntCurrentMode=mMaximizedWindow16M) then
  1411. extrastyle:=ws_maximize
  1412. else
  1413. extrastyle:=0;
  1414. { start graph subsystem }
  1415. InitializeCriticalSection(graphdrawing);
  1416. graphrunning:=false;
  1417. MessageThreadHandle:=CreateThread(nil,0,@MessageHandleThread,
  1418. nil,0,MessageThreadID);
  1419. repeat
  1420. GetExitCodeThread(MessageThreadHandle,@threadexitcode);
  1421. until graphrunning or (threadexitcode<>STILL_ACTIVE);
  1422. if threadexitcode<>STILL_ACTIVE then
  1423. _graphresult := grerror;
  1424. end;
  1425. procedure CloseGraph;
  1426. begin
  1427. If not isgraphmode then
  1428. begin
  1429. _graphresult := grnoinitgraph;
  1430. exit
  1431. end;
  1432. if UseChildWindow then
  1433. begin
  1434. { if the child window isn't destroyed }
  1435. { the main window can't be closed }
  1436. { I don't know any other way (FK) }
  1437. PostMessage(GraphWindow,wm_destroy,0,0);
  1438. PostMessage(ParentWindow,wm_destroy,0,0)
  1439. end
  1440. else
  1441. PostMessage(GraphWindow,wm_destroy,0,0);
  1442. PostThreadMessage(MessageThreadHandle,wm_quit,0,0);
  1443. WaitForSingleObject(MessageThreadHandle,Infinite);
  1444. CloseHandle(MessageThreadHandle);
  1445. DeleteCriticalSection(graphdrawing);
  1446. freemem(pal,sizeof(RGBrec)*maxcolor);
  1447. end;
  1448. procedure LineWin32GUI(X1, Y1, X2, Y2: smallint); {$ifndef fpc}far;{$endif fpc}
  1449. var X, Y : smallint;
  1450. deltax, deltay : smallint;
  1451. d, dinc1, dinc2: smallint;
  1452. xinc1 : smallint;
  1453. xinc2 : smallint;
  1454. yinc1 : smallint;
  1455. yinc2 : smallint;
  1456. i : smallint;
  1457. Flag : Boolean; { determines pixel direction in thick lines }
  1458. NumPixels : smallint;
  1459. PixelCount : smallint;
  1460. OldCurrentColor: Word;
  1461. swtmp : smallint;
  1462. TmpNumPixels : smallint;
  1463. col : longint;
  1464. pen,oldpen : hpen;
  1465. begin
  1466. if graphrunning then
  1467. begin
  1468. {******************************************}
  1469. { SOLID LINES }
  1470. {******************************************}
  1471. if lineinfo.LineStyle = SolidLn then
  1472. Begin
  1473. { Convert to global coordinates. }
  1474. x1 := x1 + StartXViewPort;
  1475. x2 := x2 + StartXViewPort;
  1476. y1 := y1 + StartYViewPort;
  1477. y2 := y2 + StartYViewPort;
  1478. { if fully clipped then exit... }
  1479. if ClipPixels then
  1480. begin
  1481. if LineClipped(x1,y1,x2,y2,StartXViewPort, StartYViewPort,
  1482. StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then
  1483. exit;
  1484. If LineInfo.Thickness=NormWidth then
  1485. Begin
  1486. EnterCriticalSection(graphdrawing);
  1487. {
  1488. if currentwritemode<>normalput then
  1489. begin
  1490. case currentwritemode of
  1491. XORPut:
  1492. begin
  1493. SetROP2(windc,R2_XORPEN);
  1494. SetROP2(bitmapdc,R2_XORPEN);
  1495. end;
  1496. AndPut:
  1497. begin
  1498. SetROP2(windc,R2_MASKPEN);
  1499. SetROP2(bitmapdc,R2_MASKPEN);
  1500. end;
  1501. OrPut:
  1502. begin
  1503. SetROP2(windc,R2_MERGEPEN);
  1504. SetROP2(bitmapdc,R2_MERGEPEN);
  1505. end;
  1506. end;
  1507. end;
  1508. }
  1509. col:=RGB(pal[CurrentColor].red,pal[CurrentColor].green,pal[CurrentColor].blue);
  1510. pen:=CreatePen(PS_SOLID,1,col);
  1511. if pen=0 then
  1512. writeln('Pen konnte nicht erzeugt werden!');
  1513. oldpen:=SelectObject(windc,pen);
  1514. MoveToEx(windc,x1,y1,nil);
  1515. Windows.LineTo(windc,x2,y2);
  1516. SetPixel(windc,x2,y2,col);
  1517. SelectObject(windc,oldpen);
  1518. oldpen:=SelectObject(bitmapdc,pen);
  1519. MoveToEx(bitmapdc,x1,y1,nil);
  1520. Windows.LineTo(bitmapdc,x2,y2);
  1521. SetPixel(bitmapdc,x2,y2,col);
  1522. SelectObject(bitmapdc,oldpen);
  1523. DeleteObject(pen);
  1524. {
  1525. if currentwritemode<>normalput then
  1526. begin
  1527. SetROP2(windc,R2_COPYPEN);
  1528. SetROP2(bitmapdc,R2_COPYPEN);
  1529. end;
  1530. }
  1531. LeaveCriticalSection(graphdrawing);
  1532. end
  1533. else
  1534. { Thick width lines }
  1535. begin
  1536. { Draw the pixels }
  1537. for i := 1 to numpixels do
  1538. begin
  1539. { all depending on the slope, we can determine }
  1540. { in what direction the extra width pixels will be put }
  1541. If Flag then
  1542. Begin
  1543. DirectPutPixelClip(x-1,y);
  1544. DirectPutPixelClip(x,y);
  1545. DirectPutPixelClip(x+1,y);
  1546. end
  1547. else
  1548. Begin
  1549. DirectPutPixelClip(x, y-1);
  1550. DirectPutPixelClip(x, y);
  1551. DirectPutPixelClip(x, y+1);
  1552. end;
  1553. if d < 0 then
  1554. begin
  1555. d := d + dinc1;
  1556. x := x + xinc1;
  1557. y := y + yinc1;
  1558. end
  1559. else
  1560. begin
  1561. d := d + dinc2;
  1562. x := x + xinc2;
  1563. y := y + yinc2;
  1564. end;
  1565. end;
  1566. end;
  1567. end;
  1568. end
  1569. else
  1570. {******************************************}
  1571. { begin patterned lines }
  1572. {******************************************}
  1573. Begin
  1574. { Convert to global coordinates. }
  1575. x1 := x1 + StartXViewPort;
  1576. x2 := x2 + StartXViewPort;
  1577. y1 := y1 + StartYViewPort;
  1578. y2 := y2 + StartYViewPort;
  1579. { if fully clipped then exit... }
  1580. if ClipPixels then
  1581. begin
  1582. if LineClipped(x1,y1,x2,y2,StartXViewPort, StartYViewPort,
  1583. StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then
  1584. exit;
  1585. end;
  1586. OldCurrentColor := CurrentColor;
  1587. PixelCount:=0;
  1588. if y1 = y2 then
  1589. Begin
  1590. { Check if we must swap }
  1591. if x1 >= x2 then
  1592. Begin
  1593. swtmp := x1;
  1594. x1 := x2;
  1595. x2 := swtmp;
  1596. end;
  1597. if LineInfo.Thickness = NormWidth then
  1598. Begin
  1599. for PixelCount:=x1 to x2 do
  1600. { optimization: PixelCount mod 16 }
  1601. if LinePatterns[PixelCount and 15] = TRUE then
  1602. begin
  1603. DirectPutPixel(PixelCount,y2);
  1604. end;
  1605. end
  1606. else
  1607. Begin
  1608. for i:=-1 to 1 do
  1609. Begin
  1610. for PixelCount:=x1 to x2 do
  1611. { Optimization from Thomas - mod 16 = and 15 }
  1612. {this optimization has been performed by the compiler
  1613. for while as well (JM)}
  1614. if LinePatterns[PixelCount and 15] = TRUE then
  1615. begin
  1616. DirectPutPixelClip(PixelCount,y2+i);
  1617. end;
  1618. end;
  1619. end;
  1620. end
  1621. else
  1622. if x1 = x2 then
  1623. Begin
  1624. { Check if we must swap }
  1625. if y1 >= y2 then
  1626. Begin
  1627. swtmp := y1;
  1628. y1 := y2;
  1629. y2 := swtmp;
  1630. end;
  1631. if LineInfo.Thickness = NormWidth then
  1632. Begin
  1633. for PixelCount:=y1 to y2 do
  1634. { compare if we should plot a pixel here , compare }
  1635. { with predefined line patterns... }
  1636. if LinePatterns[PixelCount and 15] = TRUE then
  1637. begin
  1638. DirectPutPixel(x1,PixelCount);
  1639. end;
  1640. end
  1641. else
  1642. Begin
  1643. for i:=-1 to 1 do
  1644. Begin
  1645. for PixelCount:=y1 to y2 do
  1646. { compare if we should plot a pixel here , compare }
  1647. { with predefined line patterns... }
  1648. if LinePatterns[PixelCount and 15] = TRUE then
  1649. begin
  1650. DirectPutPixelClip(x1+i,PixelCount);
  1651. end;
  1652. end;
  1653. end;
  1654. end
  1655. else
  1656. Begin
  1657. oldCurrentColor := CurrentColor;
  1658. { Calculate deltax and deltay for initialisation }
  1659. deltax := abs(x2 - x1);
  1660. deltay := abs(y2 - y1);
  1661. { Initialize all vars based on which is the independent variable }
  1662. if deltax >= deltay then
  1663. begin
  1664. Flag := FALSE;
  1665. { x is independent variable }
  1666. numpixels := deltax + 1;
  1667. d := (2 * deltay) - deltax;
  1668. dinc1 := deltay Shl 1;
  1669. dinc2 := (deltay - deltax) shl 1;
  1670. xinc1 := 1;
  1671. xinc2 := 1;
  1672. yinc1 := 0;
  1673. yinc2 := 1;
  1674. end
  1675. else
  1676. begin
  1677. Flag := TRUE;
  1678. { y is independent variable }
  1679. numpixels := deltay + 1;
  1680. d := (2 * deltax) - deltay;
  1681. dinc1 := deltax Shl 1;
  1682. dinc2 := (deltax - deltay) shl 1;
  1683. xinc1 := 0;
  1684. xinc2 := 1;
  1685. yinc1 := 1;
  1686. yinc2 := 1;
  1687. end;
  1688. { Make sure x and y move in the right directions }
  1689. if x1 > x2 then
  1690. begin
  1691. xinc1 := - xinc1;
  1692. xinc2 := - xinc2;
  1693. end;
  1694. if y1 > y2 then
  1695. begin
  1696. yinc1 := - yinc1;
  1697. yinc2 := - yinc2;
  1698. end;
  1699. { Start drawing at <x1, y1> }
  1700. x := x1;
  1701. y := y1;
  1702. If LineInfo.Thickness=ThickWidth then
  1703. Begin
  1704. TmpNumPixels := NumPixels-1;
  1705. { Draw the pixels }
  1706. for i := 0 to TmpNumPixels do
  1707. begin
  1708. { all depending on the slope, we can determine }
  1709. { in what direction the extra width pixels will be put }
  1710. If Flag then
  1711. Begin
  1712. { compare if we should plot a pixel here , compare }
  1713. { with predefined line patterns... }
  1714. if LinePatterns[i and 15] = TRUE then
  1715. begin
  1716. DirectPutPixelClip(x-1,y);
  1717. DirectPutPixelClip(x,y);
  1718. DirectPutPixelClip(x+1,y);
  1719. end;
  1720. end
  1721. else
  1722. Begin
  1723. { compare if we should plot a pixel here , compare }
  1724. { with predefined line patterns... }
  1725. if LinePatterns[i and 15] = TRUE then
  1726. begin
  1727. DirectPutPixelClip(x,y-1);
  1728. DirectPutPixelClip(x,y);
  1729. DirectPutPixelClip(x,y+1);
  1730. end;
  1731. end;
  1732. if d < 0 then
  1733. begin
  1734. d := d + dinc1;
  1735. x := x + xinc1;
  1736. y := y + yinc1;
  1737. end
  1738. else
  1739. begin
  1740. d := d + dinc2;
  1741. x := x + xinc2;
  1742. y := y + yinc2;
  1743. end;
  1744. end;
  1745. end
  1746. else
  1747. Begin
  1748. { instead of putting in loop , substract by one now }
  1749. TmpNumPixels := NumPixels-1;
  1750. { NormWidth }
  1751. for i := 0 to TmpNumPixels do
  1752. begin
  1753. if LinePatterns[i and 15] = TRUE then
  1754. begin
  1755. DirectPutPixel(x,y);
  1756. end;
  1757. if d < 0 then
  1758. begin
  1759. d := d + dinc1;
  1760. x := x + xinc1;
  1761. y := y + yinc1;
  1762. end
  1763. else
  1764. begin
  1765. d := d + dinc2;
  1766. x := x + xinc2;
  1767. y := y + yinc2;
  1768. end;
  1769. end;
  1770. end
  1771. end;
  1772. {******************************************}
  1773. { end patterned lines }
  1774. {******************************************}
  1775. { restore color }
  1776. CurrentColor:=OldCurrentColor;
  1777. end;
  1778. end;
  1779. end; { Line }
  1780. { multipage support could be done by using more than one background bitmap }
  1781. procedure SetVisualWin32GUI(page: word);
  1782. begin
  1783. end;
  1784. procedure SetActiveWin32GUI(page: word);
  1785. begin
  1786. end;
  1787. function queryadapterinfo : pmodeinfo;
  1788. var
  1789. mode: TModeInfo;
  1790. ScreenWidth,ScreenHeight : longint;
  1791. ScreenWidthMaximized,ScreenHeightMaximized : longint;
  1792. procedure SetupWin32GUIDefault;
  1793. begin
  1794. mode.DirectPutPixel:={$ifdef fpc}@{$endif}DirectPutPixel16Win32GUI;
  1795. mode.PutPixel:={$ifdef fpc}@{$endif}PutPixel16Win32GUI;
  1796. mode.GetPixel:={$ifdef fpc}@{$endif}GetPixel16Win32GUI;
  1797. mode.HLine := {$ifdef fpc}@{$endif}HLine16Win32GUI;
  1798. mode.SetRGBPalette := {$ifdef fpc}@{$endif}SetRGBPaletteWin32GUI;
  1799. mode.GetRGBPalette := {$ifdef fpc}@{$endif}GetRGBPaletteWin32GUI;
  1800. mode.SetVisualPage := {$ifdef fpc}@{$endif}SetVisualWin32GUI;
  1801. mode.SetActivePage := {$ifdef fpc}@{$endif}SetActiveWin32GUI;
  1802. mode.InitMode := {$ifdef fpc}@{$endif}InitWin32GUI16colors;
  1803. mode.OuttextXY:={$ifdef fpc}@{$endif}OuttextXYWin32GUI;
  1804. mode.VLine := {$ifdef fpc}@{$endif}VLine16Win32GUI;
  1805. // mode.circle := {$ifdef fpc}@{$endif}Circle16Win32GUI;
  1806. // doesn't work yet
  1807. // mode.Line:={$ifdef fpc}@{$endif}LineWin32GUI;
  1808. end;
  1809. begin
  1810. SaveVideoState:={$ifdef fpc}@{$endif}savestate;
  1811. RestoreVideoState:={$ifdef fpc}@{$endif}restorestate;
  1812. { we must take care of the border and caption }
  1813. ScreenWidth:=GetSystemMetrics(SM_CXSCREEN)-
  1814. 2*GetSystemMetrics(SM_CXFRAME);
  1815. ScreenHeight:=GetSystemMetrics(SM_CYSCREEN)-
  1816. 2*GetSystemMetrics(SM_CYFRAME)-
  1817. GetSystemMetrics(SM_CYCAPTION);
  1818. { for maximozed windows it's again different }
  1819. { here we've only a caption }
  1820. ScreenWidthMaximized:=GetSystemMetrics(SM_CXFULLSCREEN);
  1821. { neither GetSystemMetrics(SM_CYFULLSCREEN nor }
  1822. { SystemParametersInfo(SPI_GETWORKAREA) }
  1823. { takes a hidden try into account :( FK }
  1824. ScreenHeightMaximized:=GetSystemMetrics(SM_CYFULLSCREEN);
  1825. QueryAdapterInfo := ModeList;
  1826. { If the mode listing already exists... }
  1827. { simply return it, without changing }
  1828. { anything... }
  1829. if assigned(ModeList) then
  1830. exit;
  1831. { the first one becomes the standard mode }
  1832. if (ScreenWidth>=640) and (ScreenHeight>=480) then
  1833. begin
  1834. InitMode(mode);
  1835. mode.DriverNumber:= VGA;
  1836. mode.HardwarePages:= 0;
  1837. mode.ModeNumber:=VGAHi;
  1838. mode.ModeName:='640 x 480 x 16 Win32GUI';
  1839. mode.MaxColor := 16;
  1840. mode.PaletteSize := mode.MaxColor;
  1841. mode.DirectColor := FALSE;
  1842. mode.MaxX := 639;
  1843. mode.MaxY := 479;
  1844. SetupWin32GUIDefault;
  1845. mode.XAspect := 10000;
  1846. mode.YAspect := 10000;
  1847. AddMode(mode);
  1848. end;
  1849. if (ScreenWidth>=640) and (ScreenHeight>=200) then
  1850. begin
  1851. InitMode(mode);
  1852. { now add all standard VGA modes... }
  1853. mode.DriverNumber:= VGA;
  1854. mode.HardwarePages:= 0;
  1855. mode.ModeNumber:=VGALo;
  1856. mode.ModeName:='640 x 200 x 16 Win32GUI';
  1857. mode.MaxColor := 16;
  1858. mode.PaletteSize := mode.MaxColor;
  1859. mode.DirectColor := FALSE;
  1860. mode.MaxX := 639;
  1861. mode.MaxY := 199;
  1862. SetupWin32GUIDefault;
  1863. mode.XAspect := 10000;
  1864. mode.YAspect := 10000;
  1865. AddMode(mode);
  1866. end;
  1867. if (ScreenWidth>=640) and (ScreenHeight>=350) then
  1868. begin
  1869. InitMode(mode);
  1870. mode.DriverNumber:= VGA;
  1871. mode.HardwarePages:= 0;
  1872. mode.ModeNumber:=VGAMed;
  1873. mode.ModeName:='640 x 350 x 16 Win32GUI';
  1874. mode.MaxColor := 16;
  1875. mode.PaletteSize := mode.MaxColor;
  1876. mode.DirectColor := FALSE;
  1877. mode.MaxX := 639;
  1878. mode.MaxY := 349;
  1879. SetupWin32GUIDefault;
  1880. mode.XAspect := 10000;
  1881. mode.YAspect := 10000;
  1882. AddMode(mode);
  1883. end;
  1884. if (ScreenWidth>=640) and (ScreenHeight>=400) then
  1885. begin
  1886. InitMode(mode);
  1887. mode.DriverNumber:= VESA;
  1888. mode.HardwarePages:= 0;
  1889. mode.ModeNumber:=m640x400x256;
  1890. mode.ModeName:='640 x 400 x 256 Win32GUI';
  1891. mode.MaxColor := 256;
  1892. mode.PaletteSize := mode.MaxColor;
  1893. mode.DirectColor := FALSE;
  1894. mode.MaxX := 639;
  1895. mode.MaxY := 399;
  1896. SetupWin32GUIDefault;
  1897. mode.XAspect := 10000;
  1898. mode.YAspect := 10000;
  1899. AddMode(mode);
  1900. end;
  1901. if (ScreenWidth>=640) and (ScreenHeight>=480) then
  1902. begin
  1903. InitMode(mode);
  1904. mode.DriverNumber:= VESA;
  1905. mode.HardwarePages:= 0;
  1906. mode.ModeNumber:=m640x480x256;
  1907. mode.ModeName:='640 x 480 x 256 Win32GUI';
  1908. mode.MaxColor := 256;
  1909. mode.PaletteSize := mode.MaxColor;
  1910. mode.DirectColor := FALSE;
  1911. mode.MaxX := 639;
  1912. mode.MaxY := 479;
  1913. SetupWin32GUIDefault;
  1914. mode.XAspect := 10000;
  1915. mode.YAspect := 10000;
  1916. AddMode(mode);
  1917. end;
  1918. { add 800x600 only if screen is large enough }
  1919. If (ScreenWidth>=800) and (ScreenHeight>=600) then
  1920. begin
  1921. InitMode(mode);
  1922. mode.DriverNumber:= VESA;
  1923. mode.HardwarePages:= 0;
  1924. mode.ModeNumber:=m800x600x16;
  1925. mode.ModeName:='800 x 600 x 16 Win32GUI';
  1926. mode.MaxColor := 16;
  1927. mode.PaletteSize := mode.MaxColor;
  1928. mode.DirectColor := FALSE;
  1929. mode.MaxX := 799;
  1930. mode.MaxY := 599;
  1931. SetupWin32GUIDefault;
  1932. mode.XAspect := 10000;
  1933. mode.YAspect := 10000;
  1934. AddMode(mode);
  1935. InitMode(mode);
  1936. mode.DriverNumber:= VESA;
  1937. mode.HardwarePages:= 0;
  1938. mode.ModeNumber:=m800x600x256;
  1939. mode.ModeName:='800 x 600 x 256 Win32GUI';
  1940. mode.MaxColor := 256;
  1941. mode.PaletteSize := mode.MaxColor;
  1942. mode.DirectColor := FALSE;
  1943. mode.MaxX := 799;
  1944. mode.MaxY := 599;
  1945. SetupWin32GUIDefault;
  1946. mode.XAspect := 10000;
  1947. mode.YAspect := 10000;
  1948. AddMode(mode);
  1949. end;
  1950. { add 1024x768 only if screen is large enough }
  1951. If (ScreenWidth>=1024) and (ScreenHeight>=768) then
  1952. begin
  1953. InitMode(mode);
  1954. mode.DriverNumber:= VESA;
  1955. mode.HardwarePages:= 0;
  1956. mode.ModeNumber:=m1024x768x16;
  1957. mode.ModeName:='1024 x 768 x 16 Win32GUI';
  1958. mode.MaxColor := 16;
  1959. mode.PaletteSize := mode.MaxColor;
  1960. mode.DirectColor := FALSE;
  1961. mode.MaxX := 1023;
  1962. mode.MaxY := 767;
  1963. SetupWin32GUIDefault;
  1964. mode.XAspect := 10000;
  1965. mode.YAspect := 10000;
  1966. AddMode(mode);
  1967. InitMode(mode);
  1968. mode.DriverNumber:= VESA;
  1969. mode.HardwarePages:= 0;
  1970. mode.ModeNumber:=m1024x768x256;
  1971. mode.ModeName:='1024 x 768 x 256 Win32GUI';
  1972. mode.MaxColor := 256;
  1973. mode.PaletteSize := mode.MaxColor;
  1974. mode.DirectColor := FALSE;
  1975. mode.MaxX := 1023;
  1976. mode.MaxY := 768;
  1977. SetupWin32GUIDefault;
  1978. mode.XAspect := 10000;
  1979. mode.YAspect := 10000;
  1980. AddMode(mode);
  1981. end;
  1982. { add 1280x1024 only if screen is large enough }
  1983. If (ScreenWidth>=1280) and (ScreenHeight>=1024) then
  1984. begin
  1985. InitMode(mode);
  1986. mode.DriverNumber:= VESA;
  1987. mode.HardwarePages:= 0;
  1988. mode.ModeNumber:=m1280x1024x16;
  1989. mode.ModeName:='1280 x 1024 x 16 Win32GUI';
  1990. mode.MaxColor := 16;
  1991. mode.PaletteSize := mode.MaxColor;
  1992. mode.DirectColor := FALSE;
  1993. mode.MaxX := 1279;
  1994. mode.MaxY := 1023;
  1995. SetupWin32GUIDefault;
  1996. mode.XAspect := 10000;
  1997. mode.YAspect := 10000;
  1998. AddMode(mode);
  1999. InitMode(mode);
  2000. mode.DriverNumber:= VESA;
  2001. mode.HardwarePages:= 0;
  2002. mode.ModeNumber:=m1280x1024x256;
  2003. mode.ModeName:='1280 x 1024 x 256 Win32GUI';
  2004. mode.MaxColor := 256;
  2005. mode.PaletteSize := mode.MaxColor;
  2006. mode.DirectColor := FALSE;
  2007. mode.MaxX := 1279;
  2008. mode.MaxY := 1023;
  2009. SetupWin32GUIDefault;
  2010. mode.XAspect := 10000;
  2011. mode.YAspect := 10000;
  2012. AddMode(mode);
  2013. end;
  2014. { at least we add a mode with the largest possible window }
  2015. InitMode(mode);
  2016. mode.DriverNumber:= VESA;
  2017. mode.HardwarePages:= 0;
  2018. mode.ModeNumber:=mLargestWindow16;
  2019. mode.ModeName:='Largest Window x 16';
  2020. mode.MaxColor := 16;
  2021. mode.PaletteSize := mode.MaxColor;
  2022. mode.DirectColor := FALSE;
  2023. mode.MaxX := ScreenWidth-1;
  2024. mode.MaxY := ScreenHeight-1;
  2025. SetupWin32GUIDefault;
  2026. mode.XAspect := 10000;
  2027. mode.YAspect := 10000;
  2028. AddMode(mode);
  2029. InitMode(mode);
  2030. mode.DriverNumber:= VESA;
  2031. mode.HardwarePages:= 0;
  2032. mode.ModeNumber:=mLargestWindow256;
  2033. mode.ModeName:='Largest Window x 256';
  2034. mode.MaxColor := 256;
  2035. mode.PaletteSize := mode.MaxColor;
  2036. mode.DirectColor := FALSE;
  2037. mode.MaxX := ScreenWidth-1;
  2038. mode.MaxY := ScreenHeight-1;
  2039. SetupWin32GUIDefault;
  2040. mode.XAspect := 10000;
  2041. mode.YAspect := 10000;
  2042. AddMode(mode);
  2043. { .. and a maximized window }
  2044. InitMode(mode);
  2045. mode.DriverNumber:= VESA;
  2046. mode.HardwarePages:= 0;
  2047. mode.ModeNumber:=mMaximizedWindow16;
  2048. mode.ModeName:='Maximized Window x 16';
  2049. mode.MaxColor := 16;
  2050. mode.PaletteSize := mode.MaxColor;
  2051. mode.DirectColor := FALSE;
  2052. mode.MaxX := ScreenWidthMaximized-1;
  2053. mode.MaxY := ScreenHeightMaximized-1;
  2054. SetupWin32GUIDefault;
  2055. mode.XAspect := 10000;
  2056. mode.YAspect := 10000;
  2057. AddMode(mode);
  2058. InitMode(mode);
  2059. mode.DriverNumber:= VESA;
  2060. mode.HardwarePages:= 0;
  2061. mode.ModeNumber:=mMaximizedWindow256;
  2062. mode.ModeName:='Maximized Window x 256';
  2063. mode.MaxColor := 256;
  2064. mode.PaletteSize := mode.MaxColor;
  2065. mode.DirectColor := FALSE;
  2066. mode.MaxX := ScreenWidthMaximized-1;
  2067. mode.MaxY := ScreenHeightMaximized-1;
  2068. SetupWin32GUIDefault;
  2069. mode.XAspect := 10000;
  2070. mode.YAspect := 10000;
  2071. AddMode(mode);
  2072. end;
  2073. begin
  2074. InitializeGraph;
  2075. charmessagehandler:=nil;
  2076. mousemessagehandler:=nil;
  2077. commandmessagehandler:=nil;
  2078. notifymessagehandler:=nil;
  2079. OnGraphWindowCreation:=nil;
  2080. end.
  2081. {
  2082. $Log$
  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. }