Examplecode

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 []