← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

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

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/packages/extra/forms/demo/colbrowser.pp
 
1
Program colbrowser;
 
2
 
 
3
uses xforms,strings;
 
4
 
 
5
Const  MAX_RGB = 3000;
 
6
 
 
7
var
 
8
  cl : PFL_FORM;
 
9
  rescol, dbobj, colbr, rs, gs, bs : PFL_OBJECT;
 
10
  dbname : string;
 
11
  infile : text;
 
12
 
 
13
{ the RGB data file does not have a standard location on unix. }
 
14
{ You may need to edit this }
 
15
 
 
16
const rgbfile = '/usr/lib/X11/rgb.txt';
 
17
 
 
18
type TRGBdb = record
 
19
       r, g, b : longint;
 
20
     end;
 
21
 
 
22
var
 
23
rgbdb : array [0..MAX_RGB] of TRGBdb;
 
24
numcol : longint;
 
25
 
 
26
procedure set_entry(i : longint);
 
27
 
 
28
var
 
29
    db : TRGBdb;
 
30
 
 
31
begin
 
32
  db := rgbdb[i-1];
 
33
 
 
34
    fl_freeze_form(cl);
 
35
    fl_mapcolor(FL_FREE_COL4+i, db.r, db.g, db.b);
 
36
    fl_mapcolor(FL_FREE_COL4, db.r, db.g, db.b);
 
37
    fl_set_slider_value(rs, db.r);
 
38
    fl_set_slider_value(gs, db.g);
 
39
    fl_set_slider_value(bs, db.b);
 
40
    fl_redraw_object(rescol);
 
41
    fl_unfreeze_form(cl);
 
42
end;
 
43
 
 
44
procedure br_cb(ob : PFL_OBJECT; q :longint);cdecl;
 
45
 
 
46
var r : longint;
 
47
 
 
48
begin
 
49
    r := fl_get_browser(ob);
 
50
    if (r <= 0) then exit;
 
51
    set_entry(r - 1);
 
52
end;
 
53
 
 
54
{ slow but straightforward }
 
55
function stripsp (s : string) : string;
 
56
 
 
57
var temp : string;
 
58
    i : longint;
 
59
begin
 
60
  temp:='';
 
61
  for i:=1 to length(s) do
 
62
    if pos(s[i],'0987654321')<>0 then temp:=temp+s[i];
 
63
  stripsp:=temp;
 
64
end;
 
65
 
 
66
 
 
67
function  read_entry(Var r,g,b : longint;var name : string) : longint;
 
68
 
 
69
var
 
70
    n : longint;
 
71
    buf,temp : string;
 
72
    code : word;
 
73
 
 
74
 
 
75
begin
 
76
    readln (infile,buf);
 
77
    if buf[1]='!' then exit(0);
 
78
    temp:=stripsp(copy(buf,1,4));delete(buf,1,4);
 
79
    val (temp,r,code);
 
80
    if code<>0 then exit(0);
 
81
    temp:=stripsp(copy(buf,1,4));delete(buf,1,4);
 
82
    val (temp,g,code);
 
83
    if code<>0 then exit(0);
 
84
    temp:=stripsp(copy(buf,1,4));delete(buf,1,4);
 
85
    val (temp,b,code);
 
86
    if code<>0 then exit(0);
 
87
    { strip leading spaces from name }
 
88
    while (buf[code+1]=' ') or (buf[code+1]=#9) do inc(code);
 
89
    if code<>0 then delete(buf,1,code);
 
90
    name:=buf+#0;
 
91
    read_entry:=1;
 
92
end;
 
93
 
 
94
 
 
95
function load_browser(fname : string) : longint;
 
96
 
 
97
var buf : string;
 
98
    r,g,b : Longint;
 
99
    rr,gg,bb : string[3];
 
100
 
 
101
begin
 
102
   assign (infile,fname);
 
103
{$i-}
 
104
  reset(infile);
 
105
{$i+}
 
106
  if ioresult<>0 then
 
107
    begin
 
108
      fname:=fname+#0;
 
109
        fl_show_alert('Load', @fname[1], 'Can''t open', 0);
 
110
        exit(0);
 
111
    end;
 
112
 
 
113
    fl_freeze_form(cl);
 
114
    numcol:=-1;
 
115
    while not eof(infile) do
 
116
      begin
 
117
      if read_entry(r, g, b, buf)<>0 then
 
118
        begin
 
119
        inc(numcol);
 
120
        rgbdb[numcol].r := r;
 
121
        rgbdb[numcol].g := g;
 
122
        rgbdb[numcol].b := b;
 
123
        str (r,rr); if length(rr)<3 then rr:=copy('   ',1,3-length(rr))+rr;
 
124
        str(g,gg);if length(gg)<3 then gg:=copy('   ',1,3-length(gg))+gg;
 
125
        str(b,bb);if length(bb)<3 then bb:=copy('   ',1,3-length(bb))+bb;
 
126
        buf:='('+rr+' '+gg+' '+bb+') '+buf;
 
127
        fl_addto_browser(colbr, @buf[1]);
 
128
        end;
 
129
      end;
 
130
    close(infile);
 
131
    fl_set_browser_topline(colbr, 1);
 
132
    fl_select_browser_line(colbr, 1);
 
133
    set_entry(0);
 
134
    fl_unfreeze_form(cl);
 
135
    load_browser:=1;
 
136
end;
 
137
 
 
138
function search_entry(r,g,b : Longint) : Longint;
 
139
 
 
140
var i, j, diffr, diffg, diffb,diff, mindiff : longint;
 
141
 
 
142
begin
 
143
    mindiff := 1 shl 25;
 
144
    J:=0;
 
145
    i:=0;
 
146
    for i:=0 to numcol do
 
147
      begin
 
148
       diffr := abs(r - rgbdb[i].r);
 
149
       diffg := abs(g - rgbdb[i].g);
 
150
       diffb := abs(b - rgbdb[i].b);
 
151
       diff := round((3.0 * diffr) +
 
152
               (5.9 * diffg) +
 
153
               (1.1 * diffb));
 
154
       if (mindiff > diff) then
 
155
         begin
 
156
         mindiff := diff;
 
157
         j := i;
 
158
         end;
 
159
      end;
 
160
    search_entry:= j;
 
161
end;
 
162
 
 
163
procedure search_rgb(ob : PFL_OBJECT; q : longint);cdecl;
 
164
 
 
165
var r, g, b, i,top : longint;
 
166
 
 
167
begin
 
168
    top  := fl_get_browser_topline(colbr);
 
169
    r := round(fl_get_slider_value(rs));
 
170
    g := round(fl_get_slider_value(gs));
 
171
    b := round(fl_get_slider_value(bs));
 
172
 
 
173
    fl_freeze_form(cl);
 
174
    fl_mapcolor(FL_FREE_COL4, r, g, b);
 
175
    fl_redraw_object(rescol);
 
176
    i := search_entry(r, g, b);
 
177
    { change topline only if necessary }
 
178
    if (i < top) or (i > (top+15)) then
 
179
       fl_set_browser_topline(colbr, i-8);
 
180
    fl_select_browser_line(colbr, i + 1);
 
181
    fl_unfreeze_form(cl);
 
182
end;
 
183
 
 
184
{ change database }
 
185
procedure db_cb(ob : PFL_OBJECT; q : longint);cdecl;
 
186
 
 
187
var p: pchar;
 
188
    buf : string;
 
189
 
 
190
begin
 
191
    p := fl_show_input('Enter New Database Name', @dbname[1]);
 
192
    buf:=strpas(p)+#0;
 
193
    if buf=dbname then exit;
 
194
 
 
195
    if (load_browser(buf)<>0) then
 
196
        dbname:=buf
 
197
    else
 
198
        fl_set_object_label(ob, @dbname[1]);
 
199
end;
 
200
 
 
201
procedure done_cb (ob : PFL_OBJECT; q :  longint);cdecl;
 
202
begin
 
203
    halt(0);
 
204
end;
 
205
 
 
206
procedure create_form_cl;
 
207
var
 
208
    obj : PFL_OBJECT;
 
209
 
 
210
begin
 
211
    if (cl<>nil) then exit;
 
212
    cl := fl_bgn_form(FL_NO_BOX, 330, 385);
 
213
    obj := fl_add_box(FL_UP_BOX, 0, 0, 330, 385, '');
 
214
    fl_set_object_color(obj, FL_INDIANRED, FL_COL1);
 
215
    obj := fl_add_box(FL_NO_BOX, 40, 10, 250, 30, 'Color Browser');
 
216
    fl_set_object_lcol(obj, FL_RED);
 
217
    fl_set_object_lsize(obj, FL_HUGE_SIZE);
 
218
    fl_set_object_lstyle(obj, FL_BOLD_STYLE + FL_SHADOW_STYLE);
 
219
    obj := fl_add_button(FL_NORMAL_BUTTON, 40, 50, 250, 25, '');
 
220
    dbobj := obj ;
 
221
    fl_set_object_boxtype(obj, FL_BORDER_BOX);
 
222
{    if fl_get_visual_depth()=1 then
 
223
      fl_set_object_color(obj, FL_WHITE,FL_INDIANRED)
 
224
    else
 
225
      fl_set_object_color(obj, FL_INDIANRED, FL_INDIANRED);
 
226
}
 
227
    fl_set_object_callback(obj, PFL_CALLBACKPTR(@db_cb), 0);
 
228
 
 
229
    obj:= fl_add_valslider(FL_VERT_FILL_SLIDER, 225, 130, 30, 200, '');
 
230
    rs := obj;
 
231
    fl_set_object_color(obj, FL_INDIANRED, FL_RED);
 
232
    fl_set_slider_bounds(obj, 0, 255);
 
233
    fl_set_slider_precision(obj, 0);
 
234
    fl_set_object_callback(obj, PFL_CALLBACKPTR(@search_rgb), 0);
 
235
    fl_set_slider_return(obj, 0);
 
236
    obj:= fl_add_valslider(FL_VERT_FILL_SLIDER, 255, 130, 30, 200, '');
 
237
    gs := obj ;
 
238
    fl_set_object_color(obj, FL_INDIANRED, FL_GREEN);
 
239
    fl_set_slider_bounds(obj, 0.0, 255.0);
 
240
    fl_set_slider_precision(obj, 0);
 
241
    fl_set_object_callback(obj, PFL_CALLBACKPTR(@search_rgb), 1);
 
242
    fl_set_slider_return(obj, 0);
 
243
    obj := fl_add_valslider(FL_VERT_FILL_SLIDER, 285, 130, 30, 200, '');
 
244
    bs := obj;
 
245
    fl_set_object_color(obj, FL_INDIANRED, FL_BLUE);
 
246
    fl_set_slider_bounds(obj, double(0.0), double(255.0));
 
247
    fl_set_slider_precision(obj, 0);
 
248
    fl_set_object_callback(obj, PFL_CALLBACKPTR(@search_rgb), 2);
 
249
    fl_set_slider_return(obj, 0);
 
250
    obj := fl_add_browser(FL_HOLD_BROWSER, 10, 90, 205, 240, '');
 
251
    colbr := obj ;
 
252
    fl_set_browser_fontstyle(obj, FL_FIXED_STYLE);
 
253
    fl_set_object_callback(obj, PFL_CALLBACKPTR(@br_cb), 0);
 
254
 
 
255
    obj := fl_add_button(FL_NORMAL_BUTTON, 135, 345, 80, 30, 'Done');
 
256
    fl_set_object_callback(obj, PFL_CALLBACKPTR(@done_cb), 0);
 
257
    obj := fl_add_box(FL_FLAT_BOX, 225, 90, 90, 35, '');
 
258
    rescol := obj;
 
259
    fl_set_object_color(obj, FL_FREE_COL4, FL_FREE_COL4);
 
260
    fl_set_object_boxtype(obj, FL_BORDER_BOX);
 
261
 
 
262
    fl_end_form();
 
263
    {fl_scale_form (cl, 1.1, 1.0);}
 
264
end;
 
265
 
 
266
begin
 
267
    fl_initialize(@argc, argv, 'FormDemo', nil, 0);
 
268
    cl:=nil;
 
269
    create_form_cl();
 
270
    dbname:= rgbfile+#0;
 
271
    if (load_browser(dbname)<>0) then
 
272
        fl_set_object_label(dbobj, @dbname[1])
 
273
    else
 
274
        fl_set_object_label(dbobj, 'None');
 
275
 
 
276
    fl_set_form_minsize(cl, cl^.w , cl^.h);
 
277
    fl_set_form_maxsize(cl, 2*cl^.w , 2*cl^.h);
 
278
    fl_show_form(cl, FL_PLACE_FREE, FL_TRANSIENT, 'RGB Browser');
 
279
 
 
280
    while (fl_do_forms()<>nil) do;
 
281
end.