Examplecode

From Freepascal Amiga wiki
Jump to navigation Jump to search
The printable version is no longer supported and may have rendering errors. Please update your browser bookmarks and please use the default browser print function instead.


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

Retrieved from "http://fpcamigawiki.alb42.de/index.php?title=Examplecode&oldid=839"