/* --- Copyright University of Sussex 1997. All rights reserved. ---------- > File: $poplocal/local/auto//showpalette.p > Purpose: colour palette utility > Author: Chris J. Thornton, Apr 3 1997 > Documentation: HELP * SHOWPALETTE > Related Files: */ uses showdisplay; vars showpalette, sp_refresh, ; vars /* lvars */ sp_data = newmapping([],16,false,true), ; /* -- Generating colour maps ----------------------- */ define /* lconstant */ hex(n); lvars n = round(n); if n <= 10 then n + 47 else n + 54 endif; enddefine; define /* lconstant */ dehex(n); lvars n; if n <= `9 then n-48 else n - 55 endif; enddefine; define ved_dehex; lvars a = vedargument; dlocal pop_pr_places = 2; vedinsertstring(dehex(a(1)) / 15 >< ' ' >< dehex(a(2)) / 15 >< ' ' >< dehex(a(3)) / 15); enddefine; define /* lconstant */ col_distance(c1, c2); lvars r1 = c1(1),g1=c1(2),b1=c1(3), r2 = c2(1),g2=c2(2),b2=c2(3); (abs(r1-r2) * ((r1+r2)/2)) + (abs(g1-g2) * ((g1+g2)/2)) + (abs(b1-b2) * ((b1+b2)/2)) enddefine; define /* lconstant */ sim_col(c1, cs, min_dis); lvars c1 cs, min_dis, c2; for c2 in cs do if col_distance(c1, c2) < min_dis then return(c2) endif; endfor; return(false); enddefine; define /* lconstant */ make_colours(min_dis) -> cols; lvars j = -0.125, g, r, b, c, cols = [{0 0 0}{1 1 1}{0 0 1}{0 1 0}{1 0 0}{1 1 0}{1 0 1}{0 1 1} ], col, i, min_dis; for r from 1 by j to 0 do for g from 1 by j to 0 do for b from 1 by (j*2) to 0 do {^r ^g ^b} -> c; if not(sim_col(c, cols, min_dis)) then c :: cols -> cols endif; endfor; endfor; endfor; rev(cols) -> cols; enddefine; vars sels1, sels2; define ved_ics; vedinsertstring('[' sys_>< sels1(1) sys_>< ' ' sys_>< sels2(1) sys_>< ']\r'); enddefine; /* -- Palettes ------------------------------------- */ define /* lconstant */ handle(x,y,widget); lvars widget, x, y, x1, y1, widget, vec, item, data, c, col, l, obj, i, selections, name,map,n_rows, pdr, n, n_colours, colours, xd, yd; dlocal pop_pr_quotes = false, sd_allow_screen_display_stretching = false, sd_incremental = true, pop_pr_places = 2; explode(sp_data(sd_name(sd_widget_display(widget)) ->> name)) -> (map, colours, selections, n_rows,n_colours,pdr); length(selections) -> n; (XptVal widget (XtN height) - ((y+10) * 65536)) -> xd; (XptVal widget (XtN width) - ((x+10) * 65536)) -> yd; if xd < 0 and yd < 0 then chain(name, sp_refresh) endif; sd_X2U_coords(x,y, name) -> (x, y); map({^x ^y}) ->> col -> it; if col == "deselect" then showdisplay([ % if n == 1 then {box %0.5, y-0.5, n_rows+0.5, y+0.5% white} else {box %x-0.5, y-0.5, x+0.5, y+0.5% white} endif % {box %1,n_rows+0.6,n_rows+2,n_rows+2.5% white} ], name); if x <= n then if isprocedure(pdr) do pdr(selections(x), false); endif; false -> selections(x); endif; elseif col then for i to n-1 do quitif(not(selections(i))) endfor; n_rows + 3 -> y; showdisplay([ {box %1,n_rows+0.6,n_rows+2,n_rows+2.5% white} {string %1,n_rows+2,nullstring >< col % NavyBlue '*-i-*-15-*' } % if n == 1 then {box %0.5, y-0.5, n_rows+0.5, y+0.5, col%} else {box %i-0.5, y-0.5, i+0.5, y+0.5, col%} endif % ], name); col -> selections(i); if isprocedure(pdr) do pdr(col, true); endif; else chain(name, sp_refresh); endif; enddefine; define /* lconstant */ handle_event(widget, item, data); lvars widget, vec, item, data, c, code= exacc ^int data, x, y; if code == 1 then fast_XptValue(widget, XtN mouseX) -> x; fast_XptValue(widget, XtN mouseY) -> y; XptDeferApply(handle(%x,y,widget%)); XptSetXtWakeup(); endif; enddefine; define /* lconstant */ sp_handle_event; handle_event(); enddefine; define sp_refresh(name); lvars map = false, selections, pdr, n_rows, n_colours, col, colours,i=0, y, x; dlocal sd_hard_frame = false, sd_incremental = false; explode(sp_data(name)) -> (map,colours,selections,n_rows,n_colours,pdr); /* clear display */ showdisplay([{box 0.5 0.5 ^(n_rows+0.5) ^(n_rows+3.5) white}], name); true -> sd_incremental; /* show the instructions */ showdisplay([{string %1, n_rows+2% 'Click to select/deselect' NavyBlue '*-i-*-15-*'}], name); for x from 1 to (n_rows) do for y from 1 to (n_rows) do quitif(i >= n_colours); colours(i + 1 ->> i) -> col; showdisplay([{box ^(x-0.5) ^(y-0.5) ^(x+0.5) ^(y+0.6) ^col}], name); if map do col -> map({^x ^y}); endif; endfor; endfor; n_rows + 3 -> y; for x from 1 to n_rows do "deselect" -> map({^x ^y}) endfor; for x from 1 to length(selections) do if (selections(x) ->> col) then showdisplay([{box %x-0.5, y-0.5, x+0.5, y+0.5,col%}], name); endif; endfor; enddefine; define /* lconstant */ showpalette(x) -> selections; lvars x, n_selections, colours = sd_colours, name, n_colours, n_rows, selections = {^false}, map, widget, col, n_selections = 1, i = 0, y, pdr = false; dlocal %sd_display_size("X")% = [0 0 200 200]; if isprocedure(x) then x -> pdr; -> x endif; if isvector(x) then x -> selections; length(x) -> n_selections; -> x; endif; if isinteger(x) then x -> n_selections; {% repeat n_selections times false endrepeat %} -> selections; -> x endif; if isdecimal(x) then make_colours(x) -> colours; -> x; endif; if islist(x) then x -> colours; -> x endif; unless isstring(x ->> name) do mishap('Funny name for palette', [^x]) endunless; length(colours) -> n_colours; if n_selections < 1 then mishap('Empty initial selection vector', [^selections]) endif; round(sqrt(n_colours)) -> n_rows; if n_selections > n_rows then allbutlast(n_selections-n_rows, selections) -> selections; n_rows -> n_selections; endif; newmapping([],16,false,true) -> map; {%map,colours,selections,n_rows,n_colours,pdr%} -> sp_data(name); sp_refresh(name); sd_widget(sd_displays(name)) -> widget; XtRemoveCallback(widget, XtN buttonEvent, sp_handle_event, 0); XtAddCallback(widget, XtN buttonEvent, sp_handle_event, 0); enddefine;