We are currently migrating Bugzilla to GitHub issues.
Any changes made to the bug tracker now will be lost, so please do not post new bugs or make changes to them.
When we're done, all bug URLs will redirect to their equivalent location on the new bug tracker.

OCaml Program that crashes if you hold ESC key for 30 seconds.

main.ml (text/plain), 2.51 KB, created by simon.guilliams on 2018-01-29 14:20:19 UTC

(hide)

Description:

Filename:

MIME Type:

Creator: simon.guilliams

Created: 2018-01-29 14:20:19 UTC

Size: 2.51 KB

patch

obsolete

>(* opam install tsdl *)
>(* ocamlfind ocamlopt -package tsdl -linkpkg -thread main.ml *)
>let exit_sdl () = begin Tsdl.Sdl.quit (); exit 0 end
>let exit_err str = begin print_endline str; exit_sdl () end
>
>let sdl_try alpha = begin match alpha with
>	| Error (`Msg e) -> exit_err ("SDL error: " ^ e)
>	| Ok alpha -> alpha
>end
>
>let keycode e = Tsdl.Sdl.Event.(get e keyboard_keycode)
>
>let close_message_box () = begin
>	let d =
>		let action = {
>			Tsdl.Sdl.Message_box.button_flags = Tsdl.Sdl.Message_box.button_returnkey_default;
>			button_id = 1;
>			button_text = "Save then quit"
>		} in
>		let cancel = {
>			Tsdl.Sdl.Message_box.button_flags = Tsdl.Sdl.Message_box.button_escapekey_default;
>			button_id = 3;
>			button_text = "Cancel"
>		} in
>		let color_scheme = {
>			Tsdl.Sdl.Message_box.color_background = (255, 255, 255);
>			color_text = (255, 0, 0);
>			color_button_border = (0, 255, 0);
>			color_button_background = (0, 0, 255);
>			color_button_selected = (0, 255, 255)
>		} in
>		{
>			Tsdl.Sdl.Message_box.flags = Tsdl.Sdl.Message_box.warning; window = None; title = "Action";
>			message = "Do you want to action ?"; buttons = [cancel; action];
>			color_scheme = Some color_scheme
>		}
>	in
>	begin match Tsdl.Sdl.show_message_box d with
>	| Error (`Msg e) -> begin print_endline ("Failed to show message box") end
>	| Ok 1 -> exit_sdl ()
>	| _ -> ()
>	end
>end
>
>let prompt_exit_sdl () = begin
>	close_message_box ()
>end
>
>let redraw w = begin
>	
>	let screen = sdl_try (Tsdl.Sdl.get_window_surface w) in
>	
>	(* 0x AA RR GG BB *)
>	ignore (Tsdl.Sdl.fill_rect screen None 0x00FFFFFFl);
>	
>	ignore (Tsdl.Sdl.update_window_surface w)
>end
>
>let event_loop w =
>	let e = Tsdl.Sdl.Event.create () in
>	let rec loop () = begin
>		
>		(* Poll *)
>		(*let ret = Tsdl.Sdl.poll_event (Some e) in
>		if ret = false then () else*)
>		
>		(* Wait *)
>		sdl_try (Tsdl.Sdl.wait_event (Some e));
>		
>		begin match Tsdl.Sdl.Event.(enum (get e typ)) with
>			| `Quit									 		-> exit_sdl ()
>			| `Key_up when keycode e = Tsdl.Sdl.K.q				-> prompt_exit_sdl ()
>			
>			| `Key_down when keycode e = Tsdl.Sdl.K.escape 	-> begin prompt_exit_sdl () end
>			
>			| `Window_event -> redraw w
>			
>			| `User_event  -> redraw w
>			
>			| _ -> ()
>			
>		end;
>		loop ()
>	end in
>	
>	redraw w;
>	ignore (loop ())
>
>let main () = begin
>	
>	sdl_try (Tsdl.Sdl.init Tsdl.Sdl.Init.(video + events + timer));
>	let flags = Tsdl.Sdl.Window.(shown + mouse_focus + resizable) in
>	let w = sdl_try (Tsdl.Sdl.create_window ~w:1024 ~h:768 "Dialog bug" flags) in
>	event_loop w;
>	Tsdl.Sdl.destroy_window w;
>	Tsdl.Sdl.quit ();
>	exit 0
>end
>
>let () = main ()

Actions: View

Attachments on bug 4069: 3156

We are currently migrating Bugzilla to GitHub issues.Any changes made to the bug tracker now will be lost, so please do not post new bugs or make changes to them.When we're done, all bug URLs will redirect to their equivalent location on the new bug tracker.

We are currently migrating Bugzilla to GitHub issues.
Any changes made to the bug tracker now will be lost, so please do not post new bugs or make changes to them.
When we're done, all bug URLs will redirect to their equivalent location on the new bug tracker.