druid.ml

(**************************************************************************)
(*    Lablgtk - Examples                                                  *)
(*                                                                        *)
(*    This code is in the public domain.                                  *)
(*    You may freely copy parts of it in your application.                *)
(*                                                                        *)
(**************************************************************************)

type color = 
  | RED
  | BLUE
  | YELLOW

type food =
  | DONUTS
  | YOGHURTS
  | PIZZA

class answer = object
  val mutable color = RED
  val mutable food = DONUTS
  method answer_color c () = color <- c
  method answer_food f () = food <- f
  method get_answer = "42"
end


let radio_color poll packing =
  let f = GBin.frame ~label:"Color" ~packing () in
  let vb = GPack.vbox ~packing:f#add () in
  let rb = GButton.radio_button ~label:"Red" ~packing:(vb#pack) () in
  rb#connect#clicked (poll#answer_color RED) ;
  let rb2 = GButton.radio_button ~group:rb#group ~label:"Blue" ~packing:(vb#pack) () in
  rb2#connect#clicked (poll#answer_color BLUE) ;
  let rb3 = GButton.radio_button ~group:rb#group ~label:"Yellow" ~packing:(vb#pack) () in
  rb3#connect#clicked (poll#answer_color YELLOW)

let radio_food poll =
  let vb = GPack.vbox () in
  let rb = GButton.radio_button ~label:"Donuts" ~packing:(vb#pack) () in
  rb#connect#clicked (poll#answer_food DONUTS) ;
  let rb2 = GButton.radio_button ~group:rb#group ~label:"Pizza" ~packing:(vb#pack) () in
  rb2#connect#clicked (poll#answer_food PIZZA) ;
  let rb3 = GButton.radio_button ~group:rb#group ~label:"Yoghurt" ~packing:(vb#pack) () in
  rb3#connect#clicked (poll#answer_food YOGHURTS) ;
  vb


let are_you_sure quit =
  let md = GWindow.message_dialog 
      ~message:"Are you sure ?"
      ~message_type:`QUESTION 
      ~buttons:GWindow.Buttons.yes_no
      ~modal:true () in
  let res = md#run () = `YES in
  md#destroy () ;
  if res then quit ()


let make_druid poll quit =
  let d = GnoDruid.druid () in

  d#connect#cancel (fun () -> are_you_sure quit) ;
  
  begin 
    let fp = GnoDruid.druid_page_edge ~position:`START ~aa:true ~title:"Poll !!" () in
    fp#set_text "Here is our great new poll.\nPlease answer all the questions !" ;
    d#append_page fp 
  end ;

  begin 
    let cp = GnoDruid.druid_page_standard ~title:"Color" () in
    radio_color poll cp#vbox#pack ;
    d#append_page cp 
  end ;

  begin 
    let mp = GnoDruid.druid_page_standard ~title:"Food" () in
    mp#append_item ~question:"Favorite food ?" ~additional_info:""
      (radio_food poll)#coerce ;
    d#append_page mp 
  end ;

  begin 
    let ep = GnoDruid.druid_page_edge ~position:`FINISH ~aa:true ~title:"The end" () in
    ep#set_text "Thank you for your co-operation." ; 
    d#append_page ep ;

    ep#connect#finish 
      (fun _ -> 
	let res = GWindow.message_dialog 
	    ~message:(Printf.sprintf "The answer is %s!" poll#get_answer)
	    ~message_type:`INFO ~buttons:GWindow.Buttons.close
	    ~modal:true () in
	res#run () ;
	res#destroy () ;
	quit ())
  end ;
  d

let window_and_druid () =
  let w = GWindow.window ~title:"Druid test" () in
  let poll = new answer in
  w#add (make_druid poll GMain.quit)#coerce ;
  w#event#connect#delete 
    (fun _ -> are_you_sure GMain.quit ; true) ;
  w

let _ = 
  let w = window_and_druid () in
  w#show () ;
  GMain.main ()