fpc/packages/xforms/examples/colbrowser.pp

Program colbrowser;

uses xforms,strings;

Const  MAX_RGB = 3000;

var
  cl : PFL_FORM;
  rescol, dbobj, colbr, rs, gs, bs : PFL_OBJECT;
  dbname : string;
  infile : text;

{ the RGB data file does not have a standard location on unix. }
{ You may need to edit this }

const rgbfile = '/usr/lib/X11/rgb.txt';

type TRGBdb = record
       r, g, b : longint;
     end;

var
rgbdb : array [0..MAX_RGB] of TRGBdb;
numcol : longint;

procedure set_entry(i : longint);

var
    db : TRGBdb;

begin
  db := rgbdb[i-1];

    fl_freeze_form(cl);
    fl_mapcolor(FL_FREE_COL4+i, db.r, db.g, db.b);
    fl_mapcolor(FL_FREE_COL4, db.r, db.g, db.b);
    fl_set_slider_value(rs, db.r);
    fl_set_slider_value(gs, db.g);
    fl_set_slider_value(bs, db.b);
    fl_redraw_object(rescol);
    fl_unfreeze_form(cl);
end;

procedure br_cb(ob : PFL_OBJECT; q :longint);cdecl;

var r : longint;

begin
    r := fl_get_browser(ob);
    if (r <= 0) then exit;
    set_entry(r - 1);
end;

{ slow but straightforward }
function stripsp (s : string) : string;

var temp : string;
    i : longint;
begin
  temp:='';
  for i:=1 to length(s) do
    if pos(s[i],'0987654321')<>0 then temp:=temp+s[i];
  stripsp:=temp;
end;


function  read_entry(Var r,g,b : longint;var name : string) : longint;

var
    n : longint;
    buf,temp : string;
    code : word;


begin
    readln (infile,buf);
    if buf[1]='!' then exit(0);
    temp:=stripsp(copy(buf,1,4));delete(buf,1,4);
    val (temp,r,code);
    if code<>0 then exit(0);
    temp:=stripsp(copy(buf,1,4));delete(buf,1,4);
    val (temp,g,code);
    if code<>0 then exit(0);
    temp:=stripsp(copy(buf,1,4));delete(buf,1,4);
    val (temp,b,code);
    if code<>0 then exit(0);
    { strip leading spaces from name }
    while (buf[code+1]=' ') or (buf[code+1]=#9) do inc(code);
    if code<>0 then delete(buf,1,code);
    name:=buf+#0;
    read_entry:=1;
end;


function load_browser(fname : string) : longint;

var buf : string;
    r,g,b : Longint;
    rr,gg,bb : string[3];

begin
   assign (infile,fname);
{$push}{$i-}
  reset(infile);
{$pop}
  if ioresult<>0 then
    begin
      fname:=fname+#0;
        fl_show_alert('Load', @fname[1], 'Can''t open', 0);
        exit(0);
    end;

    fl_freeze_form(cl);
    numcol:=-1;
    while not eof(infile) do
      begin
      if read_entry(r, g, b, buf)<>0 then
        begin
        inc(numcol);
        rgbdb[numcol].r := r;
        rgbdb[numcol].g := g;
        rgbdb[numcol].b := b;
        str (r,rr); if length(rr)<3 then rr:=copy('   ',1,3-length(rr))+rr;
        str(g,gg);if length(gg)<3 then gg:=copy('   ',1,3-length(gg))+gg;
        str(b,bb);if length(bb)<3 then bb:=copy('   ',1,3-length(bb))+bb;
        buf:='('+rr+' '+gg+' '+bb+') '+buf;
        fl_addto_browser(colbr, @buf[1]);
        end;
      end;
    close(infile);
    fl_set_browser_topline(colbr, 1);
    fl_select_browser_line(colbr, 1);
    set_entry(0);
    fl_unfreeze_form(cl);
    load_browser:=1;
end;

function search_entry(r,g,b : Longint) : Longint;

var i, j, diffr, diffg, diffb,diff, mindiff : longint;

begin
    mindiff := 1 shl 25;
    J:=0;
    i:=0;
    for i:=0 to numcol do
      begin
       diffr := abs(r - rgbdb[i].r);
       diffg := abs(g - rgbdb[i].g);
       diffb := abs(b - rgbdb[i].b);
       diff := round((3.0 * diffr) +
               (5.9 * diffg) +
               (1.1 * diffb));
       if (mindiff > diff) then
         begin
         mindiff := diff;
         j := i;
         end;
      end;
    search_entry:= j;
end;

procedure search_rgb(ob : PFL_OBJECT; q : longint);cdecl;

var r, g, b, i,top : longint;

begin
    top  := fl_get_browser_topline(colbr);
    r := round(fl_get_slider_value(rs));
    g := round(fl_get_slider_value(gs));
    b := round(fl_get_slider_value(bs));

    fl_freeze_form(cl);
    fl_mapcolor(FL_FREE_COL4, r, g, b);
    fl_redraw_object(rescol);
    i := search_entry(r, g, b);
    { change topline only if necessary }
    if (i < top) or (i > (top+15)) then
       fl_set_browser_topline(colbr, i-8);
    fl_select_browser_line(colbr, i + 1);
    fl_unfreeze_form(cl);
end;

{ change database }
procedure db_cb(ob : PFL_OBJECT; q : longint);cdecl;

var p: PAnsiChar;
    buf : string;

begin
    p := fl_show_input('Enter New Database Name', @dbname[1]);
    buf:=strpas(p)+#0;
    if buf=dbname then exit;

    if (load_browser(buf)<>0) then
        dbname:=buf
    else
        fl_set_object_label(ob, @dbname[1]);
end;

procedure done_cb (ob : PFL_OBJECT; q :  longint);cdecl;
begin
    halt(0);
end;

procedure create_form_cl;
var
    obj : PFL_OBJECT;

begin
    if (cl<>nil) then exit;
    cl := fl_bgn_form(FL_NO_BOX, 330, 385);
    obj := fl_add_box(FL_UP_BOX, 0, 0, 330, 385, '');
    fl_set_object_color(obj, FL_INDIANRED, FL_COL1);
    obj := fl_add_box(FL_NO_BOX, 40, 10, 250, 30, 'Color Browser');
    fl_set_object_lcol(obj, FL_RED);
    fl_set_object_lsize(obj, FL_HUGE_SIZE);
    fl_set_object_lstyle(obj, FL_BOLD_STYLE + FL_SHADOW_STYLE);
    obj := fl_add_button(FL_NORMAL_BUTTON, 40, 50, 250, 25, '');
    dbobj := obj ;
    fl_set_object_boxtype(obj, FL_BORDER_BOX);
{    if fl_get_visual_depth()=1 then
      fl_set_object_color(obj, FL_WHITE,FL_INDIANRED)
    else
      fl_set_object_color(obj, FL_INDIANRED, FL_INDIANRED);
}
    fl_set_object_callback(obj, PFL_CALLBACKPTR(@db_cb), 0);

    obj:= fl_add_valslider(FL_VERT_FILL_SLIDER, 225, 130, 30, 200, '');
    rs := obj;
    fl_set_object_color(obj, FL_INDIANRED, FL_RED);
    fl_set_slider_bounds(obj, 0, 255);
    fl_set_slider_precision(obj, 0);
    fl_set_object_callback(obj, PFL_CALLBACKPTR(@search_rgb), 0);
    fl_set_slider_return(obj, 0);
    obj:= fl_add_valslider(FL_VERT_FILL_SLIDER, 255, 130, 30, 200, '');
    gs := obj ;
    fl_set_object_color(obj, FL_INDIANRED, FL_GREEN);
    fl_set_slider_bounds(obj, 0.0, 255.0);
    fl_set_slider_precision(obj, 0);
    fl_set_object_callback(obj, PFL_CALLBACKPTR(@search_rgb), 1);
    fl_set_slider_return(obj, 0);
    obj := fl_add_valslider(FL_VERT_FILL_SLIDER, 285, 130, 30, 200, '');
    bs := obj;
    fl_set_object_color(obj, FL_INDIANRED, FL_BLUE);
    fl_set_slider_bounds(obj, double(0.0), double(255.0));
    fl_set_slider_precision(obj, 0);
    fl_set_object_callback(obj, PFL_CALLBACKPTR(@search_rgb), 2);
    fl_set_slider_return(obj, 0);
    obj := fl_add_browser(FL_HOLD_BROWSER, 10, 90, 205, 240, '');
    colbr := obj ;
    fl_set_browser_fontstyle(obj, FL_FIXED_STYLE);
    fl_set_object_callback(obj, PFL_CALLBACKPTR(@br_cb), 0);

    obj := fl_add_button(FL_NORMAL_BUTTON, 135, 345, 80, 30, 'Done');
    fl_set_object_callback(obj, PFL_CALLBACKPTR(@done_cb), 0);
    obj := fl_add_box(FL_FLAT_BOX, 225, 90, 90, 35, '');
    rescol := obj;
    fl_set_object_color(obj, FL_FREE_COL4, FL_FREE_COL4);
    fl_set_object_boxtype(obj, FL_BORDER_BOX);

    fl_end_form();
    {fl_scale_form (cl, 1.1, 1.0);}
end;

begin
    fl_initialize(@argc, argv, 'FormDemo', nil, 0);
    cl:=nil;
    create_form_cl();
    dbname:= rgbfile+#0;
    if (load_browser(dbname)<>0) then
        fl_set_object_label(dbobj, @dbname[1])
    else
        fl_set_object_label(dbobj, 'None');

    fl_set_form_minsize(cl, cl^.w , cl^.h);
    fl_set_form_maxsize(cl, 2*cl^.w , 2*cl^.h);
    fl_show_form(cl, FL_PLACE_FREE, FL_TRANSIENT, 'RGB Browser');

    while (fl_do_forms()<>nil) do;
end.