open Sugar;;
open ListExtra;;
open Environment;;
module Image = struct
let scaleTo (width,height) pixbuf =
begin
let scaled = GdkPixbuf.create ~has_alpha:true ~width ~height () in
GdkPixbuf.scale ~dest:scaled ~width ~height ~interp:`HYPER pixbuf;
scaled
end
;;
let zoom (factor:float) pixbuf =
let formule = (fun x -> (float_of_int x) *. factor +. 0.5 ) || int_of_float in
let width = pixbuf => (GdkPixbuf.get_width || formule) in
let height = pixbuf => (GdkPixbuf.get_height || formule) in
prerr_endline ("Old width="^(string_of_int (GdkPixbuf.get_width pixbuf)));
prerr_endline ("Old height="^(string_of_int (GdkPixbuf.get_height pixbuf))^"\n");
scaleTo (width,height) pixbuf
;;
let inch_of_pixels ?(ppi=96.) (x:int) = (float_of_int x) /. ppi ;;
end;;
module DynamicSubmenu = struct
let make
?(set_active:(string->bool)=(fun x->false))
~(submenu: GMenu.menu)
~(menu: GMenu.image_menu_item)
~(dynList: unit->(string list))
~(action: string->unit->unit) () =
let recalc () = (
List.iter (submenu#remove) (submenu#children) ;
List.iter (fun x -> let i=(GMenu.check_menu_item ~active:(set_active x) ~label:x ~packing:(submenu#add) ()) in
let _ = i#connect#toggled ~callback:(action x) in ()
)
(dynList ()) ) in
let _ = menu#connect#activate ~callback:recalc in
()
;;
end;;
module ComboTextTree = struct
class comboTextTree = fun
~(generator: ((string,string) env)->(string list))
~(msg:(string,string) env)
~(key:string)
~(callback:(string->unit) option)
~(packing:(GObj.widget -> unit) option)
->
let strList = (generator msg) in
let (initial_box, (_, initial_col)) = GEdit.combo_box_text ~strings:strList () in
let _ = initial_box#set_active 0 in
object (self)
method generator : ((string,string) env -> (string list)) = generator
method key : string = key
method callback : (string -> unit) = match callback with None -> (fun x->()) | Some f -> f
method packing : (GObj.widget -> unit) = match packing with None -> (fun x->()) | Some f -> f
val mutable env : ((string,string) env) = msg
val mutable choices : (string list) = (generator msg)
val mutable box : #GEdit.combo_box = initial_box
val mutable col : ('a GTree.column) = initial_col
val mutable childs : comboTextTree list = []
method env = env
method choices = choices
method box = box
method col = col
method childs = childs
method child i = List.nth childs i
method slave = List.nth childs 0
method slave0 = List.nth childs 0
method slave1 = List.nth childs 1
method slave2 = List.nth childs 2
method slave3 = List.nth childs 3
method slave4 = List.nth childs 4
method slave5 = List.nth childs 5
method set_env r = env <- r
method set_choices l = choices <- l
method set_box b = box <- b
method set_col c = col <- c
method set_childs l = childs <- l
method add_child x = childs <- childs @ [x]
method selected =
match self#box#active_iter with
| None -> ""
| Some row -> (self#box#model#get ~row ~column:self#col)
method set_active_value (v:string) =
try
let i = raise_when_none (List.indexOf v self#choices) in
self#box#set_active i ;
self#childs_rebuild ()
with _ -> ()
method childs_rebuild () =
let msg = mkenv (self#env#get_l @ [(self#key,self#selected)]) in
List.iter (fun w -> w#rebuild msg) self#childs
method rebuild (msg:(string,string) env) =
begin
let previous = self#selected in
self#box#destroy () ;
let strList = (self#generator msg) in
let (combo, (_, column)) = GEdit.combo_box_text ~strings:strList () in
self#set_box combo ;
self#set_col column ;
self#set_choices strList ;
self#initialize_callbacks ;
self#packing (self#box :> GObj.widget) ;
self#set_env msg ;
let i = ((List.indexOf previous self#choices) |=> 0) in
(self#box#set_active i) ;
self#childs_rebuild () ;
()
end
method changedAndGetActive (cbfun:string->unit) =
let _ = self#box#connect#changed
(fun () -> match self#box#active_iter with
| None -> ()
| Some row -> let data = (self#box#model#get ~row ~column:self#col) in cbfun data
) in ()
val initialize_packing =
let _ = match packing with None -> () | Some f -> f (initial_box :> GObj.widget) in ()
method initialize_callbacks =
let _ = self#changedAndGetActive (fun x -> self#childs_rebuild ()) in
let _ = self#changedAndGetActive self#callback in ()
end;;
type choice = string;;
type choices = choice list;;
let make
~(generator: ((string,string) env)->(string list))
~(msg:(string,string) env)
~(key:string)
~(callback:(choice->unit) option)
~(packing:(GObj.widget -> unit) option)
= let self = new comboTextTree ~generator ~msg ~key ~callback ~packing in
let _ = self#initialize_callbacks in self
;;
let fromList
?(key:string="unused_key")
?(callback:((choice->unit) option) = None )
?(packing:((GObj.widget -> unit) option) = None )
(lst:choices)
= let g = (fun r -> lst) in
let m = (mkenv []) in
make ~generator:g ~msg:m ~key ~callback ~packing
;;
let fromListWithSlave
?(masterCallback:((choice->unit) option) = None)
?(masterPacking:((GObj.widget -> unit) option) = None)
(masterChoices:choices)
?(slaveCallback:((choice->unit) option) = None)
?(slavePacking:((GObj.widget -> unit) option) = None )
(slaveChoices: choice -> choices)
= let master = fromList ~key:"master" ~callback:masterCallback ~packing:masterPacking masterChoices in
let slave = make
~generator:(fun r -> slaveChoices (r#get "master"))
~msg:(mkenv [("master",master#selected)])
~key:"slave"
~callback:slaveCallback
~packing:slavePacking in
let _ = master#add_child slave in master
;;
let fromListWithSlaveWithSlave
?(masterCallback:((choice->unit) option) = None)
?(masterPacking:((GObj.widget -> unit) option) = None)
(masterChoices:choices)
?(slaveCallback:((choice->unit) option) = None)
?(slavePacking:((GObj.widget -> unit) option) = None )
(slaveChoices: choice -> choices)
?(slaveSlaveCallback:((choice->unit) option) = None)
?(slaveSlavePacking:((GObj.widget -> unit) option) = None )
(slaveSlaveChoices: choice -> choice -> choices)
= let master =
fromListWithSlave ~masterCallback ~masterPacking masterChoices ~slaveCallback ~slavePacking slaveChoices in
let slaveSlave = make
~generator:(fun r -> slaveSlaveChoices (r#get "master") (r#get "slave"))
~msg:(mkenv [("master",master#selected);("slave",master#slave#selected)])
~key:"slaveSlave"
~callback:slaveSlaveCallback
~packing:slaveSlavePacking in
let _ = master#slave#add_child slaveSlave in master
;;
let fromListWithSlaveWithSlaveWithSlave
?(masterCallback:((choice->unit) option) = None)
?(masterPacking:((GObj.widget -> unit) option) = None)
(masterChoices:choices)
?(slaveCallback:((choice->unit) option) = None)
?(slavePacking:((GObj.widget -> unit) option) = None )
(slaveChoices: choice -> choices)
?(slaveSlaveCallback:((choice->unit) option) = None)
?(slaveSlavePacking:((GObj.widget -> unit) option) = None )
(slaveSlaveChoices: choice -> choice -> choices)
?(slaveSlaveSlaveCallback:((choice->unit) option) = None)
?(slaveSlaveSlavePacking:((GObj.widget -> unit) option) = None )
(slaveSlaveSlaveChoices: choice -> choice -> choice -> choices)
= let master =
fromListWithSlaveWithSlave
~masterCallback ~masterPacking masterChoices
~slaveCallback ~slavePacking slaveChoices
~slaveSlaveCallback ~slaveSlavePacking slaveSlaveChoices in
let slaveSlaveSlave = make
~generator:(fun r -> slaveSlaveSlaveChoices (r#get "master") (r#get "slave") (r#get "slaveSlave"))
~msg:(mkenv [("master",master#selected);("slave",master#slave#selected);("slaveSlave",master#slave#slave#selected)])
~key:"slaveSlaveSlave"
~callback:slaveSlaveSlaveCallback
~packing:slaveSlaveSlavePacking in
let _ = master#slave#slave#add_child slaveSlaveSlave in master
;;
let fromListWithTwoSlaves
?(masterCallback:((choice->unit) option) = None)
?(masterPacking:((GObj.widget -> unit) option) = None)
(masterChoices:choices)
?(slave1Callback:((choice->unit) option) = None)
?(slave1Packing:((GObj.widget -> unit) option) = None )
(slave1Choices: choice -> choices)
?(slave2Callback:((choice->unit) option) = None)
?(slave2Packing:((GObj.widget -> unit) option) = None )
(slave2Choices: choice -> choices)
= let master = fromList ~key:"master" ~callback:masterCallback ~packing:masterPacking masterChoices in
let slave1 = make
~generator:(fun r -> slave1Choices (r#get "master"))
~msg:(mkenv [("master",master#selected)])
~key:"slave1"
~callback:slave1Callback
~packing:slave1Packing in
let slave2 = make
~generator:(fun r -> slave2Choices (r#get "master"))
~msg:(mkenv [("master",master#selected)])
~key:"slave2"
~callback:slave2Callback
~packing:slave2Packing in
let _ = master#add_child slave1 in
let _ = master#add_child slave2 in master
;;
end ;;
class textview = fun ?(view:GText.view = GText.view ()) () ->
let v = view in
object (self)
val view = v
val buffer = v#buffer
val mutable iter = v#buffer#get_iter_at_char 0
method view = view
method append ?(tags=[]) x =
buffer#insert ~iter:iter ~tag_names:tags x
method append_image ?(scale:((int*int) option)=None) filename =
begin
let pixbuf = GdkPixbuf.from_file filename in
let pixbuf = (match scale with
| None -> pixbuf
| Some (width,height) -> let scaled = GdkPixbuf.create ~has_alpha:true ~width ~height () in
GdkPixbuf.scale ~dest:scaled ~width ~height ~interp:`BILINEAR pixbuf; scaled) in
buffer#insert_pixbuf ~iter:iter ~pixbuf
end
method refresh () =
begin
let start,stop = buffer#bounds in
buffer#apply_tag_by_name "word_wrap" ~start ~stop ;
()
end
method delete () =
begin
let start,stop = buffer#bounds in
buffer#delete ~start ~stop ;
iter <- buffer#get_iter_at_char 0
end
method rewrite ?(tags=[]) x = self#delete () ; self#append ~tags x
method private create_tags () =
begin
let stipple = Gdk.Bitmap.create_from_data 2 2 "\002\001" in
buffer#create_tag ~name:"heading" [`WEIGHT `BOLD; `SIZE (15*Pango.scale)] => ignore ;
buffer#create_tag ~name:"italic" [`STYLE `ITALIC] => ignore ;
buffer#create_tag ~name:"bold" [`WEIGHT `BOLD] => ignore ;
buffer#create_tag ~name:"big" [`SIZE 20] => ignore ;
buffer#create_tag ~name:"xx-small" [`SCALE `XX_SMALL] => ignore ;
buffer#create_tag ~name:"x-large" [`SCALE `X_LARGE] => ignore ;
buffer#create_tag ~name:"monospace" [`FAMILY "monospace"] => ignore ;
buffer#create_tag ~name:"blue_foreground" [`FOREGROUND "blue"] => ignore ;
buffer#create_tag ~name:"red_background" [`BACKGROUND "red"] => ignore ;
buffer#create_tag ~name:"background_stipple" [`BACKGROUND_STIPPLE stipple] => ignore ;
buffer#create_tag ~name:"foreground_stipple" [`FOREGROUND_STIPPLE stipple] => ignore ;
buffer#create_tag ~name:"big_gap_before_line" [`PIXELS_ABOVE_LINES 30] => ignore ;
buffer#create_tag ~name:"big_gap_after_line" [`PIXELS_BELOW_LINES 30] => ignore ;
buffer#create_tag ~name:"double_spaced_line" [`PIXELS_INSIDE_WRAP 10] => ignore ;
buffer#create_tag ~name:"not_editable" [`EDITABLE false] => ignore ;
buffer#create_tag ~name:"word_wrap" [`WRAP_MODE `WORD] => ignore ;
buffer#create_tag ~name:"char_wrap" [`WRAP_MODE `CHAR] => ignore ;
buffer#create_tag ~name:"no_wrap" [`WRAP_MODE `NONE] => ignore ;
buffer#create_tag ~name:"center" [`JUSTIFICATION `CENTER] => ignore ;
buffer#create_tag ~name:"right_justify" [`JUSTIFICATION `RIGHT] => ignore ;
buffer#create_tag ~name:"wide_margins" [`LEFT_MARGIN 50; `RIGHT_MARGIN 50] => ignore ;
buffer#create_tag ~name:"strikethrough" [`STRIKETHROUGH true] => ignore ;
buffer#create_tag ~name:"underline" [`UNDERLINE `SINGLE] => ignore ;
buffer#create_tag ~name:"double_underline" [`UNDERLINE `DOUBLE] => ignore ;
buffer#create_tag ~name:"superscript" [`RISE (10*Pango.scale); `SIZE (8*Pango.scale)] => ignore ;
buffer#create_tag ~name:"subscript" [`RISE (-10*Pango.scale); `SIZE (8*Pango.scale)] => ignore ;
buffer#create_tag ~name:"rtl_quote"[`WRAP_MODE `WORD; `DIRECTION `RTL; `INDENT 30; `LEFT_MARGIN 20; `RIGHT_MARGIN 20] => ignore ;
()
end
initializer self#create_tags ()
end;;