← Back to branch summary

~ubuntu-branches/ubuntu/lucid/fpc/lucid-proposed

« back to all changes in this revision

Viewing changes to fpcsrc/packages/extra/forms/demo/free1.pp

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-10-09 23:29:00 UTC
  • mfrom: (4.1.1 sid)
  • Revision ID: james.westby@ubuntu.com-20081009232900-553f61m37jkp6upv
Tags: 2.2.2-4
http://bugs.debian.org/498882
[ Torsten Werner ]
* Update ABI version in fpc-depends automatically.
* Remove empty directories from binary package fpc-source.

[ Mazen Neifer ]
* Removed leading path when calling update-alternatives to remove a Linitian
  error.
* Fixed clean target.
* Improved description of packages. (Closes: #498882)

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/packages/extra/forms/demo/free1.pp
1
 
{ This demo is meant to demonstrate the use of a free
2
 
   object in a form.
3
 
}
4
 
program free1;
5
 
 
6
 
uses xforms;
7
 
 
8
 
Const
9
 
  onn : boolean = True;
10
 
  dcol : longint = 1;
11
 
 
12
 
var
13
 
  cole : TFL_COLOR;
14
 
  form : PFL_FORM;
15
 
  obj : PFL_OBJECT;
16
 
  i, j, depth, col : Longint;
17
 
  dummy : cardinal;
18
 
 
19
 
 
20
 
{ The call back routine }
21
 
function handle_it(obj : PFL_OBJECT; event : longint;
22
 
                   mx,my : TFL_Coord;
23
 
                   key : longint; ev : pointer) : longint;cdecl;
24
 
 
25
 
begin
26
 
  exit;
27
 
  case event of
28
 
    FL_DRAW:
29
 
        fl_rect(obj^.x,obj^.y,obj^.w,obj^.h, obj^.u_ldata);
30
 
    FL_RELEASE:
31
 
        onn := not(onn);
32
 
    FL_STEP:
33
 
        if (onn) then
34
 
          begin
35
 
          if (obj^.u_ldata = cole) then
36
 
              dcol := -1;
37
 
          if (obj^.u_ldata = FL_FREE_COL1) then
38
 
              dcol := 1;
39
 
          obj^.u_ldata := dcol;
40
 
          fl_redraw_object(obj);
41
 
          end;
42
 
  end;
43
 
  handle_it:=0;
44
 
end;
45
 
 
46
 
procedure done(ob : PFL_OBJECT; data : longint); cdecl;
47
 
 
48
 
begin
49
 
 halt(0)
50
 
end;
51
 
 
52
 
begin
53
 
  fl_initialize(@argc, argv, 'FormDemo', nil, 0);
54
 
  form := fl_bgn_form(FL_UP_BOX,400,400);
55
 
  obj := fl_add_button(FL_NORMAL_BUTTON,320,20,40,30,'Exit');
56
 
  fl_set_object_callback(obj, PFL_CALLBACKPTR(@done), 0);
57
 
  obj := fl_add_free(FL_CONTINUOUS_FREE,40,80,320,280
58
 
                     ,'',PFL_HANDLEPTR(@handle_it));
59
 
  fl_end_form();
60
 
  depth  := fl_get_visual_depth;
61
 
  { can't do it if less than 4 bit deep }
62
 
  if depth=8 then writeln ('depth of 8');
63
 
  if (depth < 4) then
64
 
    begin
65
 
    writeln ('This Demo requires a depth of at least 4 bits');
66
 
    halt(1);
67
 
  end;
68
 
  cole := ((1 shl depth)-1);
69
 
  if (cole > 64) then
70
 
     cole := 64;
71
 
  col := FL_FREE_COL1;
72
 
{  obj^.u_ldata := col;
73
 
}  cole := cole+col;
74
 
  i:=col;
75
 
  while i<=cole do
76
 
   begin
77
 
     j := round(255 * (i - col) /(cole  - col));
78
 
     dummy:=fl_mapcolor(i, j, j, j);
79
 
     inc(i);
80
 
   end;
81
 
 
82
 
  fl_show_form(form,FL_PLACE_CENTER,FL_NOBORDER,'Free Object');
83
 
  fl_do_forms();
84
 
end.