Difference between revisions of "Examplecode"
Jump to navigation
Jump to search
(Initial creation of page) |
|||
(One intermediate revision by the same user not shown) | |||
Line 1: | Line 1: | ||
+ | [[Category:Examples]] | ||
+ | |||
Some example-code that need preperation before they can go into the wikibook. | Some example-code that need preperation before they can go into the wikibook. | ||
+ | |||
+ | Original c-code [http://aros.sourceforge.net/documentation/developers/samplecode/helloworld.c] | ||
+ | <source lang="pascal"> | ||
+ | Program HelloWorld; | ||
+ | Begin | ||
+ | Writeln('Hello World'); | ||
+ | Exit(0); | ||
+ | End. | ||
+ | </source> | ||
+ | |||
+ | |||
+ | Original c-code [http://aros.sourceforge.net/documentation/developers/samplecode/graphics_simple.c] | ||
+ | <source lang="pascal"> | ||
+ | Program graphics_simple; | ||
+ | |||
+ | {$MODE OBJFPC} {$H+} | ||
+ | |||
+ | (* | ||
+ | Example for simple drawing routines | ||
+ | *) | ||
+ | |||
+ | |||
+ | Uses | ||
+ | chelpers, | ||
+ | amigalib, | ||
+ | aros_exec, | ||
+ | aros_graphics, | ||
+ | aros_intuition, | ||
+ | aros_utility; | ||
+ | |||
+ | |||
+ | var | ||
+ | window : pWindow; | ||
+ | cm : pColorMap; | ||
+ | rp : pRastPort; | ||
+ | |||
+ | const | ||
+ | (* | ||
+ | ObtainBestPen() returns -1 when it fails, therefore we | ||
+ | initialize the pen numbers with -1 to simplify cleanup. | ||
+ | *) | ||
+ | pen1 : A_LONG = -1; | ||
+ | pen2 : A_LONG = -1; | ||
+ | |||
+ | |||
+ | { forward declarations } | ||
+ | procedure draw_simple; forward; | ||
+ | procedure clean_exit(const s: A_CONST_STRPTR); forward; | ||
+ | procedure handle_events; forward; | ||
+ | |||
+ | |||
+ | |||
+ | Function Main: Integer; | ||
+ | begin | ||
+ | window := OpenWindowTags(nil, | ||
+ | [ | ||
+ | WA_Left , 50, | ||
+ | WA_Top , 70, | ||
+ | WA_Width , 400, | ||
+ | WA_Height , 350, | ||
+ | |||
+ | WA_Title , 'Simple Graphics', | ||
+ | WA_Activate , True, | ||
+ | WA_SmartRefresh , true, | ||
+ | WA_NoCareRefresh, true, | ||
+ | WA_GimmeZeroZero, true, | ||
+ | WA_CloseGadget , true, | ||
+ | WA_DragBar , true, | ||
+ | WA_DepthGadget , true, | ||
+ | WA_IDCMP , IDCMP_CLOSEWINDOW, | ||
+ | TAG_END | ||
+ | ]); | ||
+ | |||
+ | if not valid(window) then clean_exit('Can''t open window'); | ||
+ | |||
+ | rp := window^.RPort; | ||
+ | cm := pScreen(window^.WScreen)^.ViewPort.Colormap; | ||
+ | |||
+ | (* Let's obtain two pens *) | ||
+ | { | ||
+ | pen1 := ObtainBestPen(cm, $FFFF0000, 0, 0, TAG_END); | ||
+ | pen2 := ObtainBestPen(cm, 0 ,0, $FFFF0000, TAG_END); | ||
+ | } | ||
+ | pen1 := ObtainBestPenA(cm, $FFFF0000, 0, 0, nil); | ||
+ | pen2 := ObtainBestPenA(cm, 0 ,0, $FFFF0000, nil); | ||
+ | If (not valid(pen1) or not valid(pen2)) then clean_exit('Can''t allocate pen'); | ||
+ | |||
+ | draw_simple; | ||
+ | handle_events; | ||
+ | |||
+ | clean_exit(nil); | ||
+ | |||
+ | result := 0; | ||
+ | end; | ||
+ | |||
+ | |||
+ | |||
+ | procedure draw_simple; | ||
+ | var | ||
+ | array_ : array[0..8-1] of A_WORD; | ||
+ | begin | ||
+ | array_[0] := 50; array_[1] := 200; { Polygon for PolyDraw } | ||
+ | array_[2] := 80; array_[3] := 180; | ||
+ | array_[4] := 90; array_[5] := 220; | ||
+ | array_[6] := 50; array_[7] := 200; | ||
+ | |||
+ | SetAPen(rp, pen1); { Set foreground color } | ||
+ | SetBPen(rp, pen2); { Set background color } | ||
+ | |||
+ | WritePixel(rp, 30, 70); { Plot a point } | ||
+ | |||
+ | SetDrPt(rp, $FF00); { Change line pattern. Set pixels are drawn } | ||
+ | { with APen, unset with BPen } | ||
+ | Move(rp, 20, 50); { Move cursor to given point } | ||
+ | Draw(rp, 100, 80); { Draw a line from current to given point } | ||
+ | |||
+ | DrawEllipse(rp, 70, 30, 15, 10); { Draw an ellipse } | ||
+ | |||
+ | (* | ||
+ | Draw a polygon. Note that the first line is draw from the | ||
+ | end of the last Move() or Draw() command | ||
+ | *) | ||
+ | |||
+ | PolyDraw(rp, sizeof(array_) div sizeof(A_WORD) div 2, @array_); | ||
+ | |||
+ | SetDrMd(rp, JAM1); { We want to use only the foreground pen } | ||
+ | Move(rp, 200, 80); | ||
+ | GText(rp, 'Text in default font', 20); | ||
+ | |||
+ | SetDrPt(rp, $FFFF); { Reset line pattern } | ||
+ | end; | ||
+ | |||
+ | |||
+ | |||
+ | procedure write_text(const s: A_CONST_STRPTR; x: A_WORD; y: A_WORD; mode: A_ULONG); | ||
+ | begin | ||
+ | SetDrMd(rp, mode); | ||
+ | Move(rp, x, y); | ||
+ | GText(rp, s, strlen(s)); | ||
+ | end; | ||
+ | |||
+ | |||
+ | |||
+ | procedure handle_events; | ||
+ | var | ||
+ | imsg : pIntuiMessage; | ||
+ | port : pMsgPort; | ||
+ | terminated : boolean; | ||
+ | begin | ||
+ | (* | ||
+ | A simple event handler. This will be exaplained ore detailed | ||
+ | in the Intuition examples. | ||
+ | *) | ||
+ | port := window^.userPort; | ||
+ | terminated := false; | ||
+ | |||
+ | while not terminated do | ||
+ | begin | ||
+ | Wait(1 shl port^.mp_SigBit); | ||
+ | if (Assign(imsg, GetMsg(port)) <> nil) then | ||
+ | begin | ||
+ | Case imsg^.IClass of | ||
+ | IDCMP_CLOSEWINDOW : terminated := true; | ||
+ | end; { case } | ||
+ | ReplyMsg(pMessage(imsg)); | ||
+ | end; | ||
+ | |||
+ | end; | ||
+ | end; | ||
+ | |||
+ | |||
+ | |||
+ | procedure clean_exit(const s: A_CONST_STRPTR); | ||
+ | begin | ||
+ | If valid(s) then WriteLn(s); | ||
+ | |||
+ | (* Give back allocated resources *) | ||
+ | if (pen1 <> -1) then ReleasePen(cm, pen1); | ||
+ | if (pen2 <> -1) then ReleasePen(cm, pen2); | ||
+ | if valid(window) then CloseWindow(window); | ||
+ | end; | ||
+ | |||
+ | |||
+ | |||
+ | Begin | ||
+ | Main(); | ||
+ | end. | ||
+ | </source> | ||
+ | |||
+ | |||
+ | |||
+ | Original c-code [http://aros.sourceforge.net/documentation/developers/samplecode/graphics_bitmap.c] | ||
+ | <source lang="pascal"> | ||
+ | Program graphics_bitmap; | ||
+ | |||
+ | {$MODE OBJFPC} {$H+} | ||
+ | |||
+ | (* | ||
+ | Example for bitmaps | ||
+ | *) | ||
+ | |||
+ | Uses | ||
+ | chelpers, | ||
+ | amigalib, | ||
+ | aros_exec, | ||
+ | aros_graphics, | ||
+ | aros_intuition, | ||
+ | aros_utility; | ||
+ | |||
+ | |||
+ | var | ||
+ | window : pWindow; | ||
+ | cm : pColorMap; | ||
+ | win_rp : pRastPort; | ||
+ | |||
+ | Const | ||
+ | BMWIDTH = (50); | ||
+ | BMHEIGHT = (50); | ||
+ | |||
+ | var | ||
+ | bm : pBitmap; | ||
+ | bm_rp : pRastPort; | ||
+ | |||
+ | const | ||
+ | (* | ||
+ | ObtainBestPen() returns -1 when it fails, therefore we | ||
+ | initialize the pen numbers with -1 to simplify cleanup. | ||
+ | *) | ||
+ | pen1 : A_LONG = -1; | ||
+ | pen2 : A_LONG = -1; | ||
+ | |||
+ | |||
+ | { forward declarations } | ||
+ | procedure draw_bitmap; forward; | ||
+ | procedure clean_exit(const s: A_CONST_STRPTR); forward; | ||
+ | procedure handle_events; forward; | ||
+ | |||
+ | |||
+ | { | ||
+ | function RASSIZE(w: integer; h: Integer): Integer; inline; | ||
+ | begin | ||
+ | result := ( (h) * ( ((w)+15) shr 3 and $FFFE )); | ||
+ | end; | ||
+ | } | ||
+ | Procedure DrawCircle(rp: pRastPort; cx: A_LONG; cy: A_LONG; r:A_LONG); inline; | ||
+ | begin | ||
+ | DrawEllipse(rp, cx, cy, r, r); | ||
+ | end; | ||
+ | |||
+ | |||
+ | |||
+ | |||
+ | Function Main: Integer; | ||
+ | begin | ||
+ | window := OpenWindowTags(nil, | ||
+ | [ | ||
+ | WA_Left , 50, | ||
+ | WA_Top , 70, | ||
+ | WA_Width , 400, | ||
+ | WA_Height , 350, | ||
+ | |||
+ | WA_Title , 'Bitmap Graphics', | ||
+ | WA_Activate , True, | ||
+ | WA_SmartRefresh , true, | ||
+ | WA_NoCareRefresh, true, | ||
+ | WA_GimmeZeroZero, true, | ||
+ | WA_CloseGadget , true, | ||
+ | WA_DragBar , true, | ||
+ | WA_DepthGadget , true, | ||
+ | WA_IDCMP , IDCMP_CLOSEWINDOW, | ||
+ | TAG_END | ||
+ | ]); | ||
+ | |||
+ | if not valid(window) then clean_exit('Can''t open window'); | ||
+ | |||
+ | win_rp := window^.RPort; | ||
+ | cm := pScreen(window^.WScreen)^.ViewPort.Colormap; | ||
+ | |||
+ | (* Let's obtain two pens *) | ||
+ | { | ||
+ | pen1 := ObtainBestPen(cm, $FFFF0000, 0, 0, TAG_END); | ||
+ | pen2 := ObtainBestPen(cm, 0 ,0, $FFFF0000, TAG_END); | ||
+ | } | ||
+ | pen1 := ObtainBestPenA(cm, $FFFF0000, 0, 0, nil); | ||
+ | pen2 := ObtainBestPenA(cm, 0 ,0, $FFFF0000, nil); | ||
+ | |||
+ | If (not valid(pen1) or not valid(pen2)) then clean_exit('Can''t allocate pen'); | ||
+ | |||
+ | draw_bitmap; | ||
+ | handle_events; | ||
+ | |||
+ | clean_exit(nil); | ||
+ | |||
+ | result := 0; | ||
+ | end; | ||
+ | |||
+ | |||
+ | |||
+ | procedure draw_bitmap; | ||
+ | var | ||
+ | Depth : A_UWORD; x: integer; | ||
+ | begin | ||
+ | (* | ||
+ | Get the depth of the screen. Don't peek in the structures, always use | ||
+ | GetBitMapAttr(). | ||
+ | *) | ||
+ | |||
+ | depth := GetBitMapAttr(win_rp^.BitMap, BMA_DEPTH); | ||
+ | |||
+ | (* | ||
+ | Create new bitmap. With BMF_MINPLANES and the bitmap pointer we are saying | ||
+ | that we want a bitmap which is smaller than the target bitmap. | ||
+ | *) | ||
+ | bm := AllocBitMap(BMWIDTH, BMHEIGHT, depth, BMF_MINPLANES, win_rp^.BitMap); | ||
+ | if not valid(bm) then clean_exit('Can''t allocate bitmap'); | ||
+ | |||
+ | bm_rp := CreateRastPort; { create rastport for our bitmap } | ||
+ | if not valid(bm_rp) then clean_exit('Can''t allocate rastport!'); | ||
+ | bm_rp^.Bitmap := bm; | ||
+ | |||
+ | (* | ||
+ | Now we can draw into our bitmap. Take care that the bitmap has no | ||
+ | clipping rectangle. This means we must not draw over the limits. | ||
+ | *) | ||
+ | |||
+ | SetRast(bm_rp, 0); { fill whole bitmap with color 0 } | ||
+ | SetAPen(bm_rp, pen1); | ||
+ | DrawCircle(bm_rp, 24, 24, 24); | ||
+ | SetAPen(bm_rp, pen2); | ||
+ | move(bm_rp, 0, 0); | ||
+ | Draw(bm_rp, 49, 49); | ||
+ | Move(bm_rp, 49, 0); | ||
+ | Draw(bm_rp, 0, 49); | ||
+ | Draw(bm_rp, 49, 49); | ||
+ | Draw(bm_rp, 49, 0); | ||
+ | Draw(bm_rp, 0, 0); | ||
+ | Draw(bm_rp, 0, 49); | ||
+ | |||
+ | |||
+ | { for x := 20 to pred(400) step 30 do } | ||
+ | x := 20; | ||
+ | while x < 400 do | ||
+ | begin | ||
+ | (* Blit the bitmap into the window *) | ||
+ | ClipBlit(bm_rp, 0, 0, win_rp, x, x div 2, BMWIDTH, BMHEIGHT, $C0); | ||
+ | inc(x, 30); | ||
+ | end; | ||
+ | end; | ||
+ | |||
+ | |||
+ | |||
+ | procedure handle_events; | ||
+ | var | ||
+ | imsg : pIntuiMessage; | ||
+ | port : pMsgPort; | ||
+ | terminated : boolean; | ||
+ | begin | ||
+ | (* | ||
+ | A simple event handler. This will be exaplained ore detailed | ||
+ | in the Intuition examples. | ||
+ | *) | ||
+ | port := window^.userPort; | ||
+ | terminated := false; | ||
+ | |||
+ | while not terminated do | ||
+ | begin | ||
+ | Wait(1 shl port^.mp_SigBit); | ||
+ | if (Assign(imsg, GetMsg(port)) <> nil) then | ||
+ | begin | ||
+ | Case imsg^.IClass of | ||
+ | IDCMP_CLOSEWINDOW : terminated := true; | ||
+ | end; { case } | ||
+ | ReplyMsg(pMessage(imsg)); | ||
+ | end; | ||
+ | |||
+ | end; | ||
+ | end; | ||
+ | |||
+ | |||
+ | |||
+ | procedure clean_exit(const s: A_CONST_STRPTR); | ||
+ | begin | ||
+ | If valid(s) then WriteLn(s); | ||
+ | |||
+ | (* Give back allocated resources *) | ||
+ | if valid(bm) then FreeBitMap(bm); | ||
+ | if valid(bm_rp) then FreeRastPort(bm_rp); | ||
+ | if (pen1 <> -1) then ReleasePen(cm, pen1); | ||
+ | if (pen2 <> -1) then ReleasePen(cm, pen2); | ||
+ | if valid(window) then CloseWindow(window); | ||
+ | end; | ||
+ | |||
+ | |||
+ | |||
+ | Begin | ||
+ | Main(); | ||
+ | end. | ||
+ | </source> | ||
+ | |||
+ | |||
+ | |||
+ | Original c-code [http://aros.sourceforge.net/documentation/developers/samplecode/graphics_area.c] | ||
+ | <source lang="pascal"> | ||
+ | Program graphics_area; | ||
+ | |||
+ | {$MODE OBJFPC} {$H+} | ||
+ | |||
+ | (* | ||
+ | Example for area drawing routines | ||
+ | *) | ||
+ | |||
+ | Uses | ||
+ | chelpers, | ||
+ | amigalib, | ||
+ | aros_exec, | ||
+ | aros_graphics, | ||
+ | aros_intuition, | ||
+ | aros_utility; | ||
+ | |||
+ | |||
+ | var | ||
+ | window : pWindow; | ||
+ | cm : pColorMap; | ||
+ | rp : pRastPort; | ||
+ | |||
+ | const | ||
+ | (* | ||
+ | ObtainBestPen() returns -1 when it fails, therefore we | ||
+ | initialize the pen numbers with -1 to simplify cleanup. | ||
+ | *) | ||
+ | pen1 : A_LONG = -1; | ||
+ | pen2 : A_LONG = -1; | ||
+ | |||
+ | MAX_POINTS = 50; | ||
+ | |||
+ | var | ||
+ | ai : TAreaInfo; | ||
+ | tr : TTmpRas; | ||
+ | trbuf : Pointer; | ||
+ | aibuf : array[0..(MAX_POINTS+1)*5] of A_UBYTE; | ||
+ | |||
+ | |||
+ | { forward declarations } | ||
+ | procedure draw_area; forward; | ||
+ | procedure clean_exit(const s: A_CONST_STRPTR); forward; | ||
+ | procedure handle_events; forward; | ||
+ | |||
+ | |||
+ | |||
+ | function RASSIZE(w: integer; h: Integer): Integer; inline; | ||
+ | begin | ||
+ | result := ( (h) * ( ((w)+15) shr 3 and $FFFE )); | ||
+ | end; | ||
+ | |||
+ | |||
+ | |||
+ | |||
+ | Function Main: Integer; | ||
+ | begin | ||
+ | window := OpenWindowTags(nil, | ||
+ | [ | ||
+ | WA_Left, 50, | ||
+ | WA_Top, 70, | ||
+ | WA_Width, 400, | ||
+ | WA_Height, 350, | ||
+ | |||
+ | WA_Title, 'Area Graphics', | ||
+ | WA_Activate, True, | ||
+ | WA_SmartRefresh, true, | ||
+ | WA_NoCareRefresh, true, | ||
+ | WA_GimmeZeroZero, true, | ||
+ | WA_CloseGadget, true, | ||
+ | WA_DragBar, true, | ||
+ | WA_DepthGadget, true, | ||
+ | WA_IDCMP, IDCMP_CLOSEWINDOW, | ||
+ | TAG_END | ||
+ | ]); | ||
+ | |||
+ | if not valid(window) then clean_exit('Can''t open window'); | ||
+ | |||
+ | rp := window^.RPort; | ||
+ | cm := pScreen(window^.WScreen)^.ViewPort.Colormap; | ||
+ | |||
+ | (* Let's obtain two pens *) | ||
+ | { | ||
+ | pen1 := ObtainBestPen(cm, $FFFF0000, 0, 0, TAG_END); | ||
+ | pen2 := ObtainBestPen(cm, 0 ,0, $FFFF0000, TAG_END); | ||
+ | } | ||
+ | pen1 := ObtainBestPenA(cm, $FFFF0000, 0, 0, nil); | ||
+ | pen2 := ObtainBestPenA(cm, 0 ,0, $FFFF0000, nil); | ||
+ | |||
+ | If (not valid(pen1) or not valid(pen2)) then clean_exit('Can''t allocate pen'); | ||
+ | |||
+ | draw_area; | ||
+ | handle_events; | ||
+ | |||
+ | clean_exit(nil); | ||
+ | |||
+ | result := 0; | ||
+ | end; | ||
+ | |||
+ | |||
+ | |||
+ | procedure draw_area; | ||
+ | begin | ||
+ | (* | ||
+ | The area drawing functions need two additional | ||
+ | structures, which have to be linked with the rastport. | ||
+ | |||
+ | First we set the AreaInfo. | ||
+ | The size of 'aibuf' must be at least 5 times the number | ||
+ | of vertexes. | ||
+ | Take care: when you define the variable 'aibuf' locally, you | ||
+ | have to set all fields to 0. | ||
+ | *) | ||
+ | |||
+ | InitArea(@ai, @aibuf, sizeOf(aibuf) div 5); | ||
+ | |||
+ | (* | ||
+ | Then we allocate a raster. It must have the size of | ||
+ | the drawing area. We have a GimmeZeroZero window with | ||
+ | no size gadget, therefore we can use the GZZ sizes. | ||
+ | *) | ||
+ | |||
+ | trbuf := AllocRaster(window^.GZZWidth, window^.GZZHeight); | ||
+ | if not valid(trbuf) then clean_exit('TmpRas buffer allocation failed!'); | ||
+ | |||
+ | (* | ||
+ | The raster must be initialized. The reason for RASSIZE() is | ||
+ | that we must round up the width to a 16 bit value | ||
+ | *) | ||
+ | InitTmpRas(@tr, trbuf, RASSIZE(window^.GZZWidth, Window^.GZZHeight)); | ||
+ | |||
+ | rp^.AreaInfo := @ai; { Link areainfo to rastport } | ||
+ | rp^.TmpRas := @tr; { Link tempras to rastport } | ||
+ | |||
+ | SetAPen(rp, pen1); { Set foreground color } | ||
+ | SetBPen(rp, pen2); { Set background color } | ||
+ | |||
+ | AreaMove(rp, 50, 200); { set start point of 1st triangle } | ||
+ | AreaDraw(rp, 300, 100); | ||
+ | AreaDraw(rp, 280, 300); | ||
+ | |||
+ | AreaMove(rp, 200, 50); { Set start point of 2nd triangle } | ||
+ | AreaDraw(rp, 210, 100); | ||
+ | AreaDraw(rp, 300, 75); | ||
+ | |||
+ | AreaEllipse(rp, 70, 70, 40, 30); { Add an ellipse } | ||
+ | |||
+ | AreaEnd(rp); { Do the rendering } | ||
+ | end; | ||
+ | |||
+ | |||
+ | |||
+ | procedure handle_events; | ||
+ | var | ||
+ | imsg : pIntuiMessage; | ||
+ | port : pMsgPort; | ||
+ | terminated : boolean; | ||
+ | begin | ||
+ | (* | ||
+ | A siple event handler. This will be exaplained ore detailed | ||
+ | in the Intuition examples. | ||
+ | *) | ||
+ | port := window^.userPort; | ||
+ | terminated := false; | ||
+ | |||
+ | while not terminated do | ||
+ | begin | ||
+ | Wait(1 shl port^.mp_SigBit); | ||
+ | if (Assign(imsg, GetMsg(port)) <> nil) then | ||
+ | begin | ||
+ | Case imsg^.IClass of | ||
+ | IDCMP_CLOSEWINDOW : terminated := true; | ||
+ | end; { case } | ||
+ | ReplyMsg(pMessage(imsg)); | ||
+ | end; | ||
+ | |||
+ | end; | ||
+ | end; | ||
+ | |||
+ | |||
+ | |||
+ | procedure clean_exit(const s: A_CONST_STRPTR); | ||
+ | begin | ||
+ | If valid(s) then WriteLn(s); | ||
+ | |||
+ | (* Give back allocated resources *) | ||
+ | if valid(trbuf) then FreeRaster(trbuf, window^.GZZWidth, window^.GZZHeight); | ||
+ | if (pen1 <> -1) then ReleasePen(cm, pen1); | ||
+ | if (pen2 <> -1) then ReleasePen(cm, pen2); | ||
+ | if valid(window) then CloseWindow(window); | ||
+ | |||
+ | end; | ||
+ | |||
+ | |||
+ | |||
+ | Begin | ||
+ | Main(); | ||
+ | end. | ||
+ | </source> | ||
+ | |||
+ | |||
+ | |||
+ | Original c-code [http://aros.sourceforge.net/documentation/developers/samplecode/graphics_font.c] | ||
+ | <source lang="pascal"> | ||
+ | Program graphics_font; | ||
+ | |||
+ | {$MODE OBJFPC} {$H+} | ||
+ | |||
+ | (* | ||
+ | Example for fonts | ||
+ | *) | ||
+ | |||
+ | |||
+ | Uses | ||
+ | chelpers, | ||
+ | amigalib, | ||
+ | aros_exec, | ||
+ | aros_graphics, | ||
+ | aros_intuition, | ||
+ | aros_diskfont, | ||
+ | aros_utility; | ||
+ | |||
+ | |||
+ | var | ||
+ | window : pWindow; | ||
+ | cm : pColorMap; | ||
+ | rp : pRastPort; | ||
+ | font : pTextFont; | ||
+ | |||
+ | const | ||
+ | (* | ||
+ | ObtainBestPen() returns -1 when it fails, therefore we | ||
+ | initialize the pen numbers with -1 to simplify cleanup. | ||
+ | *) | ||
+ | pen1 : A_LONG = -1; | ||
+ | pen2 : A_LONG = -1; | ||
+ | |||
+ | |||
+ | { forward declarations } | ||
+ | procedure draw_font; forward; | ||
+ | procedure write_text(const s: A_CONST_STRPTR; x: A_WORD; y: A_WORD; mode: A_ULONG); forward; | ||
+ | procedure clean_exit(const s: A_CONST_STRPTR); forward; | ||
+ | procedure handle_events; forward; | ||
+ | |||
+ | |||
+ | |||
+ | Function Main: Integer; | ||
+ | begin | ||
+ | window := OpenWindowTags(nil, | ||
+ | [ | ||
+ | WA_Left , 50, | ||
+ | WA_Top , 70, | ||
+ | WA_Width , 400, | ||
+ | WA_Height , 350, | ||
+ | |||
+ | WA_Title , 'Fonts', | ||
+ | WA_Activate , True, | ||
+ | WA_SmartRefresh , true, | ||
+ | WA_NoCareRefresh, true, | ||
+ | WA_GimmeZeroZero, true, | ||
+ | WA_CloseGadget , true, | ||
+ | WA_DragBar , true, | ||
+ | WA_DepthGadget , true, | ||
+ | WA_IDCMP , IDCMP_CLOSEWINDOW, | ||
+ | TAG_END | ||
+ | ]); | ||
+ | |||
+ | if not valid(window) then clean_exit('Can''t open window'); | ||
+ | |||
+ | rp := window^.RPort; | ||
+ | cm := pScreen(window^.WScreen)^.ViewPort.Colormap; | ||
+ | |||
+ | (* Let's obtain two pens *) | ||
+ | { | ||
+ | pen1 := ObtainBestPen(cm, $FFFF0000, 0, 0, TAG_END); | ||
+ | pen2 := ObtainBestPen(cm, 0 ,0, $FFFF0000, TAG_END); | ||
+ | } | ||
+ | pen1 := ObtainBestPenA(cm, $FFFF0000, 0, 0, nil); | ||
+ | pen2 := ObtainBestPenA(cm, 0 ,0, $FFFF0000, nil); | ||
+ | |||
+ | If (not valid(pen1) or not valid(pen2)) then clean_exit('Can''t allocate pen'); | ||
+ | |||
+ | draw_font; | ||
+ | handle_events; | ||
+ | |||
+ | clean_exit(nil); | ||
+ | |||
+ | result := 0; | ||
+ | end; | ||
+ | |||
+ | |||
+ | |||
+ | procedure draw_font; | ||
+ | var | ||
+ | style : A_ULONG; | ||
+ | ta : TTextAttr; | ||
+ | begin | ||
+ | ta.ta_name := 'arial.font'; { Font name } | ||
+ | ta.ta_YSize := 15; { Font size } | ||
+ | ta.ta_Style := FSF_ITALIC or FSF_BOLD; { Font style } | ||
+ | ta.ta_Flags := 0; | ||
+ | |||
+ | if not valid(assign(font, OpenDiskFont(@ta))) then | ||
+ | begin | ||
+ | clean_exit('Can''t open font'); | ||
+ | end; | ||
+ | |||
+ | |||
+ | SetAPen(rp, pen1); | ||
+ | SetBPen(rp, pen2); | ||
+ | |||
+ | SetFont(rp, font); { Linking the font to the rastport } | ||
+ | |||
+ | (* | ||
+ | In the TextAttr above we've queried a font with the styles italic and bold. | ||
+ | OpenDiskFont() tries to open a font with this styles. If this fails | ||
+ | the styles have to be generated algorithmically. To avoid that a | ||
+ | style will be added to a font which has already the style intrinsically, | ||
+ | we've first to ask. AskSoftStyle() returns a mask where all bits for styles | ||
+ | which have to be added algorithmically are set. | ||
+ | *) | ||
+ | style := AskSoftStyle(rp); | ||
+ | |||
+ | (* | ||
+ | We finally set the style. SetSoftStyle() compares with the mask from | ||
+ | AskSoftStyle() to avoid that an intrinsic style is applied again. | ||
+ | *) | ||
+ | SetSoftStyle(rp, style, FSF_ITALIC or FSF_BOLD); | ||
+ | |||
+ | (* | ||
+ | Now we write some text. Additionally the effects of the | ||
+ | rastport modes are demonstrated | ||
+ | *) | ||
+ | write_text('JAM1' , 100, 60, JAM1); | ||
+ | write_text('JAM2' , 100, 80, JAM2); | ||
+ | write_text('COMPLEMENT' , 100, 100, COMPLEMENT); | ||
+ | write_text('INVERSVID' , 100, 120, INVERSVID); | ||
+ | write_text('JAM1|INVERSVID' , 100, 140, JAM1 or INVERSVID); | ||
+ | write_text('JAM2|INVERSVID' , 100, 160, JAM2 or INVERSVID); | ||
+ | write_text('COMPLEMENT|INVERSVID' , 100, 180, COMPLEMENT or INVERSVID); | ||
+ | end; | ||
+ | |||
+ | |||
+ | |||
+ | procedure write_text(const s: A_CONST_STRPTR; x: A_WORD; y: A_WORD; mode: A_ULONG); | ||
+ | begin | ||
+ | SetDrMd(rp, mode); | ||
+ | Move(rp, x, y); | ||
+ | GText(rp, s, strlen(s)); | ||
+ | end; | ||
+ | |||
+ | |||
+ | |||
+ | procedure handle_events; | ||
+ | var | ||
+ | imsg : pIntuiMessage; | ||
+ | port : pMsgPort; | ||
+ | terminated : boolean; | ||
+ | begin | ||
+ | (* | ||
+ | A simple event handler. This will be exaplained ore detailed | ||
+ | in the Intuition examples. | ||
+ | *) | ||
+ | port := window^.userPort; | ||
+ | terminated := false; | ||
+ | |||
+ | while not terminated do | ||
+ | begin | ||
+ | Wait(1 shl port^.mp_SigBit); | ||
+ | if (Assign(imsg, GetMsg(port)) <> nil) then | ||
+ | begin | ||
+ | Case imsg^.IClass of | ||
+ | IDCMP_CLOSEWINDOW : terminated := true; | ||
+ | end; { case } | ||
+ | ReplyMsg(pMessage(imsg)); | ||
+ | end; | ||
+ | |||
+ | end; | ||
+ | end; | ||
+ | |||
+ | |||
+ | |||
+ | procedure clean_exit(const s: A_CONST_STRPTR); | ||
+ | begin | ||
+ | If valid(s) then WriteLn(s); | ||
+ | |||
+ | (* Give back allocated resources *) | ||
+ | if (pen1 <> -1) then ReleasePen(cm, pen1); | ||
+ | if (pen2 <> -1) then ReleasePen(cm, pen2); | ||
+ | if valid(font) then CloseFont(font); | ||
+ | if valid(window) then CloseWindow(window); | ||
+ | end; | ||
+ | |||
+ | |||
+ | |||
+ | Begin | ||
+ | Main(); | ||
+ | end. | ||
+ | </source> | ||
+ | |||
+ | |||
+ | |||
+ | Original c-code [] | ||
+ | <source lang="pascal"> | ||
+ | |||
+ | </source> | ||
+ | |||
+ | |||
+ | |||
+ | Original c-code [] | ||
+ | <source lang="pascal"> | ||
+ | |||
+ | </source> | ||
+ | |||
+ | |||
+ | |||
+ | Original c-code [] | ||
+ | <source lang="pascal"> | ||
+ | |||
+ | </source> | ||
+ | |||
+ | |||
+ | |||
+ | Original c-code [] | ||
+ | <source lang="pascal"> | ||
+ | |||
+ | </source> | ||
+ | |||
+ | |||
+ | |||
+ | Original c-code [] | ||
+ | <source lang="pascal"> | ||
+ | |||
+ | </source> | ||
+ | |||
+ | |||
+ | |||
+ | Original c-code [] | ||
+ | <source lang="pascal"> | ||
+ | |||
+ | </source> | ||
+ | |||
+ | |||
+ | |||
+ | Original c-code [] | ||
+ | <source lang="pascal"> | ||
+ | |||
+ | </source> |
Latest revision as of 19:25, 13 September 2017
Some example-code that need preperation before they can go into the wikibook.
Original c-code [1]
Program HelloWorld;
Begin
Writeln('Hello World');
Exit(0);
End.
Original c-code [2]
Program graphics_simple;
{$MODE OBJFPC} {$H+}
(*
Example for simple drawing routines
*)
Uses
chelpers,
amigalib,
aros_exec,
aros_graphics,
aros_intuition,
aros_utility;
var
window : pWindow;
cm : pColorMap;
rp : pRastPort;
const
(*
ObtainBestPen() returns -1 when it fails, therefore we
initialize the pen numbers with -1 to simplify cleanup.
*)
pen1 : A_LONG = -1;
pen2 : A_LONG = -1;
{ forward declarations }
procedure draw_simple; forward;
procedure clean_exit(const s: A_CONST_STRPTR); forward;
procedure handle_events; forward;
Function Main: Integer;
begin
window := OpenWindowTags(nil,
[
WA_Left , 50,
WA_Top , 70,
WA_Width , 400,
WA_Height , 350,
WA_Title , 'Simple Graphics',
WA_Activate , True,
WA_SmartRefresh , true,
WA_NoCareRefresh, true,
WA_GimmeZeroZero, true,
WA_CloseGadget , true,
WA_DragBar , true,
WA_DepthGadget , true,
WA_IDCMP , IDCMP_CLOSEWINDOW,
TAG_END
]);
if not valid(window) then clean_exit('Can''t open window');
rp := window^.RPort;
cm := pScreen(window^.WScreen)^.ViewPort.Colormap;
(* Let's obtain two pens *)
{
pen1 := ObtainBestPen(cm, $FFFF0000, 0, 0, TAG_END);
pen2 := ObtainBestPen(cm, 0 ,0, $FFFF0000, TAG_END);
}
pen1 := ObtainBestPenA(cm, $FFFF0000, 0, 0, nil);
pen2 := ObtainBestPenA(cm, 0 ,0, $FFFF0000, nil);
If (not valid(pen1) or not valid(pen2)) then clean_exit('Can''t allocate pen');
draw_simple;
handle_events;
clean_exit(nil);
result := 0;
end;
procedure draw_simple;
var
array_ : array[0..8-1] of A_WORD;
begin
array_[0] := 50; array_[1] := 200; { Polygon for PolyDraw }
array_[2] := 80; array_[3] := 180;
array_[4] := 90; array_[5] := 220;
array_[6] := 50; array_[7] := 200;
SetAPen(rp, pen1); { Set foreground color }
SetBPen(rp, pen2); { Set background color }
WritePixel(rp, 30, 70); { Plot a point }
SetDrPt(rp, $FF00); { Change line pattern. Set pixels are drawn }
{ with APen, unset with BPen }
Move(rp, 20, 50); { Move cursor to given point }
Draw(rp, 100, 80); { Draw a line from current to given point }
DrawEllipse(rp, 70, 30, 15, 10); { Draw an ellipse }
(*
Draw a polygon. Note that the first line is draw from the
end of the last Move() or Draw() command
*)
PolyDraw(rp, sizeof(array_) div sizeof(A_WORD) div 2, @array_);
SetDrMd(rp, JAM1); { We want to use only the foreground pen }
Move(rp, 200, 80);
GText(rp, 'Text in default font', 20);
SetDrPt(rp, $FFFF); { Reset line pattern }
end;
procedure write_text(const s: A_CONST_STRPTR; x: A_WORD; y: A_WORD; mode: A_ULONG);
begin
SetDrMd(rp, mode);
Move(rp, x, y);
GText(rp, s, strlen(s));
end;
procedure handle_events;
var
imsg : pIntuiMessage;
port : pMsgPort;
terminated : boolean;
begin
(*
A simple event handler. This will be exaplained ore detailed
in the Intuition examples.
*)
port := window^.userPort;
terminated := false;
while not terminated do
begin
Wait(1 shl port^.mp_SigBit);
if (Assign(imsg, GetMsg(port)) <> nil) then
begin
Case imsg^.IClass of
IDCMP_CLOSEWINDOW : terminated := true;
end; { case }
ReplyMsg(pMessage(imsg));
end;
end;
end;
procedure clean_exit(const s: A_CONST_STRPTR);
begin
If valid(s) then WriteLn(s);
(* Give back allocated resources *)
if (pen1 <> -1) then ReleasePen(cm, pen1);
if (pen2 <> -1) then ReleasePen(cm, pen2);
if valid(window) then CloseWindow(window);
end;
Begin
Main();
end.
Original c-code [3]
Program graphics_bitmap;
{$MODE OBJFPC} {$H+}
(*
Example for bitmaps
*)
Uses
chelpers,
amigalib,
aros_exec,
aros_graphics,
aros_intuition,
aros_utility;
var
window : pWindow;
cm : pColorMap;
win_rp : pRastPort;
Const
BMWIDTH = (50);
BMHEIGHT = (50);
var
bm : pBitmap;
bm_rp : pRastPort;
const
(*
ObtainBestPen() returns -1 when it fails, therefore we
initialize the pen numbers with -1 to simplify cleanup.
*)
pen1 : A_LONG = -1;
pen2 : A_LONG = -1;
{ forward declarations }
procedure draw_bitmap; forward;
procedure clean_exit(const s: A_CONST_STRPTR); forward;
procedure handle_events; forward;
{
function RASSIZE(w: integer; h: Integer): Integer; inline;
begin
result := ( (h) * ( ((w)+15) shr 3 and $FFFE ));
end;
}
Procedure DrawCircle(rp: pRastPort; cx: A_LONG; cy: A_LONG; r:A_LONG); inline;
begin
DrawEllipse(rp, cx, cy, r, r);
end;
Function Main: Integer;
begin
window := OpenWindowTags(nil,
[
WA_Left , 50,
WA_Top , 70,
WA_Width , 400,
WA_Height , 350,
WA_Title , 'Bitmap Graphics',
WA_Activate , True,
WA_SmartRefresh , true,
WA_NoCareRefresh, true,
WA_GimmeZeroZero, true,
WA_CloseGadget , true,
WA_DragBar , true,
WA_DepthGadget , true,
WA_IDCMP , IDCMP_CLOSEWINDOW,
TAG_END
]);
if not valid(window) then clean_exit('Can''t open window');
win_rp := window^.RPort;
cm := pScreen(window^.WScreen)^.ViewPort.Colormap;
(* Let's obtain two pens *)
{
pen1 := ObtainBestPen(cm, $FFFF0000, 0, 0, TAG_END);
pen2 := ObtainBestPen(cm, 0 ,0, $FFFF0000, TAG_END);
}
pen1 := ObtainBestPenA(cm, $FFFF0000, 0, 0, nil);
pen2 := ObtainBestPenA(cm, 0 ,0, $FFFF0000, nil);
If (not valid(pen1) or not valid(pen2)) then clean_exit('Can''t allocate pen');
draw_bitmap;
handle_events;
clean_exit(nil);
result := 0;
end;
procedure draw_bitmap;
var
Depth : A_UWORD; x: integer;
begin
(*
Get the depth of the screen. Don't peek in the structures, always use
GetBitMapAttr().
*)
depth := GetBitMapAttr(win_rp^.BitMap, BMA_DEPTH);
(*
Create new bitmap. With BMF_MINPLANES and the bitmap pointer we are saying
that we want a bitmap which is smaller than the target bitmap.
*)
bm := AllocBitMap(BMWIDTH, BMHEIGHT, depth, BMF_MINPLANES, win_rp^.BitMap);
if not valid(bm) then clean_exit('Can''t allocate bitmap');
bm_rp := CreateRastPort; { create rastport for our bitmap }
if not valid(bm_rp) then clean_exit('Can''t allocate rastport!');
bm_rp^.Bitmap := bm;
(*
Now we can draw into our bitmap. Take care that the bitmap has no
clipping rectangle. This means we must not draw over the limits.
*)
SetRast(bm_rp, 0); { fill whole bitmap with color 0 }
SetAPen(bm_rp, pen1);
DrawCircle(bm_rp, 24, 24, 24);
SetAPen(bm_rp, pen2);
move(bm_rp, 0, 0);
Draw(bm_rp, 49, 49);
Move(bm_rp, 49, 0);
Draw(bm_rp, 0, 49);
Draw(bm_rp, 49, 49);
Draw(bm_rp, 49, 0);
Draw(bm_rp, 0, 0);
Draw(bm_rp, 0, 49);
{ for x := 20 to pred(400) step 30 do }
x := 20;
while x < 400 do
begin
(* Blit the bitmap into the window *)
ClipBlit(bm_rp, 0, 0, win_rp, x, x div 2, BMWIDTH, BMHEIGHT, $C0);
inc(x, 30);
end;
end;
procedure handle_events;
var
imsg : pIntuiMessage;
port : pMsgPort;
terminated : boolean;
begin
(*
A simple event handler. This will be exaplained ore detailed
in the Intuition examples.
*)
port := window^.userPort;
terminated := false;
while not terminated do
begin
Wait(1 shl port^.mp_SigBit);
if (Assign(imsg, GetMsg(port)) <> nil) then
begin
Case imsg^.IClass of
IDCMP_CLOSEWINDOW : terminated := true;
end; { case }
ReplyMsg(pMessage(imsg));
end;
end;
end;
procedure clean_exit(const s: A_CONST_STRPTR);
begin
If valid(s) then WriteLn(s);
(* Give back allocated resources *)
if valid(bm) then FreeBitMap(bm);
if valid(bm_rp) then FreeRastPort(bm_rp);
if (pen1 <> -1) then ReleasePen(cm, pen1);
if (pen2 <> -1) then ReleasePen(cm, pen2);
if valid(window) then CloseWindow(window);
end;
Begin
Main();
end.
Original c-code [4]
Program graphics_area;
{$MODE OBJFPC} {$H+}
(*
Example for area drawing routines
*)
Uses
chelpers,
amigalib,
aros_exec,
aros_graphics,
aros_intuition,
aros_utility;
var
window : pWindow;
cm : pColorMap;
rp : pRastPort;
const
(*
ObtainBestPen() returns -1 when it fails, therefore we
initialize the pen numbers with -1 to simplify cleanup.
*)
pen1 : A_LONG = -1;
pen2 : A_LONG = -1;
MAX_POINTS = 50;
var
ai : TAreaInfo;
tr : TTmpRas;
trbuf : Pointer;
aibuf : array[0..(MAX_POINTS+1)*5] of A_UBYTE;
{ forward declarations }
procedure draw_area; forward;
procedure clean_exit(const s: A_CONST_STRPTR); forward;
procedure handle_events; forward;
function RASSIZE(w: integer; h: Integer): Integer; inline;
begin
result := ( (h) * ( ((w)+15) shr 3 and $FFFE ));
end;
Function Main: Integer;
begin
window := OpenWindowTags(nil,
[
WA_Left, 50,
WA_Top, 70,
WA_Width, 400,
WA_Height, 350,
WA_Title, 'Area Graphics',
WA_Activate, True,
WA_SmartRefresh, true,
WA_NoCareRefresh, true,
WA_GimmeZeroZero, true,
WA_CloseGadget, true,
WA_DragBar, true,
WA_DepthGadget, true,
WA_IDCMP, IDCMP_CLOSEWINDOW,
TAG_END
]);
if not valid(window) then clean_exit('Can''t open window');
rp := window^.RPort;
cm := pScreen(window^.WScreen)^.ViewPort.Colormap;
(* Let's obtain two pens *)
{
pen1 := ObtainBestPen(cm, $FFFF0000, 0, 0, TAG_END);
pen2 := ObtainBestPen(cm, 0 ,0, $FFFF0000, TAG_END);
}
pen1 := ObtainBestPenA(cm, $FFFF0000, 0, 0, nil);
pen2 := ObtainBestPenA(cm, 0 ,0, $FFFF0000, nil);
If (not valid(pen1) or not valid(pen2)) then clean_exit('Can''t allocate pen');
draw_area;
handle_events;
clean_exit(nil);
result := 0;
end;
procedure draw_area;
begin
(*
The area drawing functions need two additional
structures, which have to be linked with the rastport.
First we set the AreaInfo.
The size of 'aibuf' must be at least 5 times the number
of vertexes.
Take care: when you define the variable 'aibuf' locally, you
have to set all fields to 0.
*)
InitArea(@ai, @aibuf, sizeOf(aibuf) div 5);
(*
Then we allocate a raster. It must have the size of
the drawing area. We have a GimmeZeroZero window with
no size gadget, therefore we can use the GZZ sizes.
*)
trbuf := AllocRaster(window^.GZZWidth, window^.GZZHeight);
if not valid(trbuf) then clean_exit('TmpRas buffer allocation failed!');
(*
The raster must be initialized. The reason for RASSIZE() is
that we must round up the width to a 16 bit value
*)
InitTmpRas(@tr, trbuf, RASSIZE(window^.GZZWidth, Window^.GZZHeight));
rp^.AreaInfo := @ai; { Link areainfo to rastport }
rp^.TmpRas := @tr; { Link tempras to rastport }
SetAPen(rp, pen1); { Set foreground color }
SetBPen(rp, pen2); { Set background color }
AreaMove(rp, 50, 200); { set start point of 1st triangle }
AreaDraw(rp, 300, 100);
AreaDraw(rp, 280, 300);
AreaMove(rp, 200, 50); { Set start point of 2nd triangle }
AreaDraw(rp, 210, 100);
AreaDraw(rp, 300, 75);
AreaEllipse(rp, 70, 70, 40, 30); { Add an ellipse }
AreaEnd(rp); { Do the rendering }
end;
procedure handle_events;
var
imsg : pIntuiMessage;
port : pMsgPort;
terminated : boolean;
begin
(*
A siple event handler. This will be exaplained ore detailed
in the Intuition examples.
*)
port := window^.userPort;
terminated := false;
while not terminated do
begin
Wait(1 shl port^.mp_SigBit);
if (Assign(imsg, GetMsg(port)) <> nil) then
begin
Case imsg^.IClass of
IDCMP_CLOSEWINDOW : terminated := true;
end; { case }
ReplyMsg(pMessage(imsg));
end;
end;
end;
procedure clean_exit(const s: A_CONST_STRPTR);
begin
If valid(s) then WriteLn(s);
(* Give back allocated resources *)
if valid(trbuf) then FreeRaster(trbuf, window^.GZZWidth, window^.GZZHeight);
if (pen1 <> -1) then ReleasePen(cm, pen1);
if (pen2 <> -1) then ReleasePen(cm, pen2);
if valid(window) then CloseWindow(window);
end;
Begin
Main();
end.
Original c-code [5]
Program graphics_font;
{$MODE OBJFPC} {$H+}
(*
Example for fonts
*)
Uses
chelpers,
amigalib,
aros_exec,
aros_graphics,
aros_intuition,
aros_diskfont,
aros_utility;
var
window : pWindow;
cm : pColorMap;
rp : pRastPort;
font : pTextFont;
const
(*
ObtainBestPen() returns -1 when it fails, therefore we
initialize the pen numbers with -1 to simplify cleanup.
*)
pen1 : A_LONG = -1;
pen2 : A_LONG = -1;
{ forward declarations }
procedure draw_font; forward;
procedure write_text(const s: A_CONST_STRPTR; x: A_WORD; y: A_WORD; mode: A_ULONG); forward;
procedure clean_exit(const s: A_CONST_STRPTR); forward;
procedure handle_events; forward;
Function Main: Integer;
begin
window := OpenWindowTags(nil,
[
WA_Left , 50,
WA_Top , 70,
WA_Width , 400,
WA_Height , 350,
WA_Title , 'Fonts',
WA_Activate , True,
WA_SmartRefresh , true,
WA_NoCareRefresh, true,
WA_GimmeZeroZero, true,
WA_CloseGadget , true,
WA_DragBar , true,
WA_DepthGadget , true,
WA_IDCMP , IDCMP_CLOSEWINDOW,
TAG_END
]);
if not valid(window) then clean_exit('Can''t open window');
rp := window^.RPort;
cm := pScreen(window^.WScreen)^.ViewPort.Colormap;
(* Let's obtain two pens *)
{
pen1 := ObtainBestPen(cm, $FFFF0000, 0, 0, TAG_END);
pen2 := ObtainBestPen(cm, 0 ,0, $FFFF0000, TAG_END);
}
pen1 := ObtainBestPenA(cm, $FFFF0000, 0, 0, nil);
pen2 := ObtainBestPenA(cm, 0 ,0, $FFFF0000, nil);
If (not valid(pen1) or not valid(pen2)) then clean_exit('Can''t allocate pen');
draw_font;
handle_events;
clean_exit(nil);
result := 0;
end;
procedure draw_font;
var
style : A_ULONG;
ta : TTextAttr;
begin
ta.ta_name := 'arial.font'; { Font name }
ta.ta_YSize := 15; { Font size }
ta.ta_Style := FSF_ITALIC or FSF_BOLD; { Font style }
ta.ta_Flags := 0;
if not valid(assign(font, OpenDiskFont(@ta))) then
begin
clean_exit('Can''t open font');
end;
SetAPen(rp, pen1);
SetBPen(rp, pen2);
SetFont(rp, font); { Linking the font to the rastport }
(*
In the TextAttr above we've queried a font with the styles italic and bold.
OpenDiskFont() tries to open a font with this styles. If this fails
the styles have to be generated algorithmically. To avoid that a
style will be added to a font which has already the style intrinsically,
we've first to ask. AskSoftStyle() returns a mask where all bits for styles
which have to be added algorithmically are set.
*)
style := AskSoftStyle(rp);
(*
We finally set the style. SetSoftStyle() compares with the mask from
AskSoftStyle() to avoid that an intrinsic style is applied again.
*)
SetSoftStyle(rp, style, FSF_ITALIC or FSF_BOLD);
(*
Now we write some text. Additionally the effects of the
rastport modes are demonstrated
*)
write_text('JAM1' , 100, 60, JAM1);
write_text('JAM2' , 100, 80, JAM2);
write_text('COMPLEMENT' , 100, 100, COMPLEMENT);
write_text('INVERSVID' , 100, 120, INVERSVID);
write_text('JAM1|INVERSVID' , 100, 140, JAM1 or INVERSVID);
write_text('JAM2|INVERSVID' , 100, 160, JAM2 or INVERSVID);
write_text('COMPLEMENT|INVERSVID' , 100, 180, COMPLEMENT or INVERSVID);
end;
procedure write_text(const s: A_CONST_STRPTR; x: A_WORD; y: A_WORD; mode: A_ULONG);
begin
SetDrMd(rp, mode);
Move(rp, x, y);
GText(rp, s, strlen(s));
end;
procedure handle_events;
var
imsg : pIntuiMessage;
port : pMsgPort;
terminated : boolean;
begin
(*
A simple event handler. This will be exaplained ore detailed
in the Intuition examples.
*)
port := window^.userPort;
terminated := false;
while not terminated do
begin
Wait(1 shl port^.mp_SigBit);
if (Assign(imsg, GetMsg(port)) <> nil) then
begin
Case imsg^.IClass of
IDCMP_CLOSEWINDOW : terminated := true;
end; { case }
ReplyMsg(pMessage(imsg));
end;
end;
end;
procedure clean_exit(const s: A_CONST_STRPTR);
begin
If valid(s) then WriteLn(s);
(* Give back allocated resources *)
if (pen1 <> -1) then ReleasePen(cm, pen1);
if (pen2 <> -1) then ReleasePen(cm, pen2);
if valid(font) then CloseFont(font);
if valid(window) then CloseWindow(window);
end;
Begin
Main();
end.
Original c-code []
Original c-code []
Original c-code []
Original c-code []
Original c-code []
Original c-code []
Original c-code []