module ShowTimeProfile;

import StdEnv;

import Help;

ApplicationName :==  "ShowTimeProfile";
HelpFileName :== ApplicationName +++ "Help";

PCorMac pc mac :== mac;

:: Profile = {
		module_name::String,		
		function_name::String,
		n_strict_calls::Int,
		n_lazy_calls::Int,
		n_curried_calls::Int,
		n_allocated_words::Int,
		time::Real
	};

:: FormattedProfile = {
	f_module_name::String,
	f_function_name::String,
	f_n_strict_calls::Int,
	f_n_lazy_calls::Int,
	f_n_curried_calls::Int,
	f_n_allocated_bytes::Int,
	f_alloc_percentage::Real,
	f_time::Real,
	f_time_percentage::Real
};

format_string_r length string
	# string_size=size string;
	| string_size >= length
		= string;
		= (createArray (length-string_size) ' ')+++string;

format_real n_spaces n d m r
	| r<0.0
		= format_negative_real (if (n_spaces<1) 0 (dec n_spaces)) n d m (~r);
	# s=toString (toInt (m*r));
	  l=size s;
	| l<=d
		= createArray n_spaces ' ' +++ createArray n '0' +++"."+++createArray (d-l) '0'+++s;
	| l<=n+d
		= createArray n_spaces ' ' +++ createArray (n+d-l) '0' +++insert_dot_in_string s l d;
	| l<=n_spaces+n+d
		= createArray (n_spaces+n+d-l) ' '+++ insert_dot_in_string s l d;
		= insert_dot_in_string s l d;

format_negative_real n_spaces n d m r
	# s=toString (toInt (m*r));
	  l=size s;
	| l<=d
		= createArray n_spaces ' ' +++"-"+++ createArray n '0' +++"."+++ createArray (d-l) '0' +++s;
	| l<=n+d
		= createArray n_spaces ' ' +++"-"+++ createArray (n+d-l) '0' +++insert_dot_in_string s l d;
	| l<=n_spaces+n+d
		= createArray (n_spaces+n+d-l) ' ' +++ "-"+++insert_dot_in_string s l d;
		= "-"+++insert_dot_in_string s l d;

insert_dot_in_string s l d = s % (0,l-1-d) +++"."+++ s % (l-d,l-1);

format_profile total_strict_calls total_lazy_calls total_curried_calls total_allocation total_time profile_list
	= ([format_profile p \\ p<-profile_list],
	   {
	   
		f_module_name = "All Modules",
	   
	  	f_function_name="Total",
	  	f_n_strict_calls=total_strict_calls,
	  	f_n_lazy_calls=total_lazy_calls,
		f_n_curried_calls=total_curried_calls,
		f_n_allocated_bytes=PCorMac total_allocation (total_allocation<<2),
		f_alloc_percentage=100.0,
		f_time=total_time,
		f_time_percentage=100.0
	   });
{
	format_profile {module_name,function_name,n_strict_calls,n_lazy_calls,n_curried_calls,n_allocated_words,time}
		=	{
			f_module_name=module_name,
			f_function_name=function_name,
			f_time=time,
			f_time_percentage=(time*100.0)/total_time,
			f_n_allocated_bytes=PCorMac n_allocated_words (n_allocated_words<<2),
			f_alloc_percentage=(toReal (n_allocated_words)*100.0)/toReal total_allocation,
			f_n_strict_calls=n_strict_calls,
			f_n_lazy_calls=n_lazy_calls,
			f_n_curried_calls=n_curried_calls
			};
}

sum_time_and_allocation l = foldl add_time_and_allocation (0,0,0,0,0.0) l;
{
	add_time_and_allocation (s,l,c,a,t) {function_name,n_strict_calls,n_lazy_calls,n_curried_calls,n_allocated_words,time}
		| n_allocated_words>=0
			= (s+n_strict_calls,l+n_lazy_calls,c+n_curried_calls,a+n_allocated_words,t+time)
			= (s+n_strict_calls,l+n_lazy_calls,c+n_curried_calls,a,t+time);
}

totals_per_module []
	= [];
totals_per_module [f=:{module_name}:l]
	# (functions,l) = split_at_next_module l;
		with {
			split_at_next_module []
				= ([],[]);
			split_at_next_module l=:[f=:{module_name=m}:t]
				| m==module_name
					# (functions,l) = split_at_next_module t;
					= ([f:functions],l);
					= ([],l);
		}
	# functions = [f:functions];
	# (total_strict_calls,total_lazy_calls,total_curried_calls,total_allocation,total_time) = sum_time_and_allocation functions;
	# new_module =
		{module_name=module_name,
		function_name="Module "+++module_name,
		n_strict_calls=total_strict_calls,
		n_lazy_calls=total_lazy_calls,
		n_curried_calls=total_curried_calls,
		n_allocated_words=total_allocation,
		time=total_time
	  };
	= [new_module:totals_per_module l];

read_profile file
	# (processor,processor_clock,bus_clock,file) = read_processor_information file;
//	# (_,clock_speed,overhead) = clock_speed_and_profile_overhead;
	# clock_speed=abort "read_profile";
	# overhead=abort "read_profile";
	= read_function_profiles (PCorMac (compute_time_x86 (clock_speed*1.0E6) overhead) (compute_time processor processor_clock bus_clock)) file;

read_processor_information file
	# (ok,processor,file)=freadi file;
	| not ok
		= error file;
	# (ok,processor_clock,file)=freadi file;
	| not ok
		= error file;
	# (ok,bus_clock,file)=freadi file;
	| not ok
		= error file;
	# (ok,c,file) = freadc file;
	| not ok || c<>'\n'
		= error file;
		= (processor,processor_clock,bus_clock,file);
	{}{
		error file = (0,1,1,file);
	}

TwoPower32Real:==4294967296.0;

PowerPC601GestaltNumber:==257;
PowerPC750GestaltNumber:==264;
PowerPC7400GestaltNumber:==268;

PowerPC603604ProfileOverhead:==10.0;
PowerPC750ProfileOverhead:==7.0;

compute_time processor processor_clock bus_clock
	| processor==PowerPC601GestaltNumber
		= \ (time_hi,time_lo,n_profiler_calls)
			-> toReal time_hi + (toReal time_lo / 1E+9) - (toReal n_profiler_calls*16.0/toReal processor_clock);
	| processor>=PowerPC750GestaltNumber
		= \ (time_hi,time_lo,n_profiler_calls)
			-> ((toReal time_hi*TwoPower32Real + (if (time_lo>=0) (toReal time_lo) (TwoPower32Real+toReal time_lo)))*4.0)/toReal bus_clock
		 		- (toReal n_profiler_calls*PowerPC750ProfileOverhead/toReal processor_clock);
		= \ (time_hi,time_lo,n_profiler_calls)
			-> ((toReal time_hi*TwoPower32Real + (if (time_lo>=0) (toReal time_lo) (TwoPower32Real+toReal time_lo)))*4.0)/toReal bus_clock
		 		- (toReal n_profiler_calls*PowerPC603604ProfileOverhead/toReal processor_clock);

compute_time_x86 processor_clock profile_overhead
	= \ (time_hi,time_lo,n_profiler_calls)
		-> (toReal time_hi*TwoPower32Real + (if (time_lo>=0) (toReal time_lo) (TwoPower32Real+toReal time_lo)))/toReal processor_clock
			- (toReal n_profiler_calls*profile_overhead/toReal processor_clock);

read_function_profiles compute_time_function file
	# (ok,function_profile,file) = read_function_profile file;
	| not ok
		= ([],file);
		# (profile,file) = read_function_profiles compute_time_function file;
		= ([function_profile : profile],file);
{}{
	read_function_profile file
		# (ok,module_name,file) = read_function_name file;
		| not ok
			= error file;

		# (ok,function_name,file) = read_function_name file;
		| not ok
			= error file;
		# (ok,n_strict_calls,file)=freadi file;
		| not ok
			= error file;
		# (ok,n_lazy_calls,file)=freadi file;
		| not ok
			= error file;
		# (ok,n_curried_calls,file)=freadi file;
		| not ok
			= error file;
		# (ok,n_profiler_calls,file)=freadi file;
		| not ok
			= error file;
		# (ok,n_allocated_words,file)=freadi file;
		| not ok
			= error file;
		# (ok,time_hi,file)=freadi file;
		| not ok
			= error file;
		# (ok,time_lo,file)=freadi file;
		| not ok
			= error file;
		# (ok,c,file) = freadc file;
		| not ok || c<>'\n'
			= error file;
			# time = compute_time_function (time_hi,time_lo,n_profiler_calls);
			= (True,{				module_name=module_name,
									function_name=function_name,n_strict_calls=n_strict_calls,n_lazy_calls=n_lazy_calls,
									n_curried_calls=n_curried_calls,n_allocated_words=n_allocated_words,time=time},file);
		{}{
			error file = (False,abort "error in read_function_profile",file);
		}

		read_function_name file
			# (ok,c,file) = freadc file;
			| not ok || c==' ' || c=='\n'
				= (False,"",file);
				# (_,s,file) = read_function_name file
				= (True,toString c+++s,file);
}

ge_profile_time {f_time=time1}{f_time=time2} = time1>=time2;

import deltaEventIO,deltaPicture, deltaIOState;
from deltaWindow import DrawInActiveWindowFrame,ChangePictureDomain,DrawInWindow;
from deltaSystem import MaxFixedWindowSize;
from deltaFileSelect import SelectInputFile;
from deltaWindow import OpenWindows,CloseWindows;
from deltaMenu import EnableMenus,DisableMenus,EnableMenuItems,DisableMenuItems;

(<::) infix;
(<::) f t:== f a b; { (a,b)=t };

(AP3) infix;
(AP3) f t:== f a b c; { (a,b,c)=t };

(>:) infixl;
(>:) f g:== g f;

draw_string_at position s picture
	:== picture >: MovePenTo position >: DrawString s;

monaco9_font
	# (ok,font)=SelectFont (PCorMac "Arial" "Monaco") [] 9;
	| ok
		= font;

geneva6_font
	# (ok,font)=SelectFont (PCorMac "Arial" "Geneva") [] (PCorMac 7 6);
	= font;

geneva8_font
	# (ok,font)=SelectFont (PCorMac "Arial" "Geneva") [] (PCorMac 9 8);
	= font;

Pos0:==4;
Pos1:==300;
Pos2:==440;
Pos3:==540;
Pos4:==600;
Pos5:==680;
Pos6:==740;
Pos7:==800;
Pos8:==860;
WindowWidth:==940;

PPrinterPos0:==2;
PPrinterPos1:==30*5;
PPrinterPos2:==44*5;
PPrinterPos3:==54*5;
PPrinterPos4:==60*5;
PPrinterPos5:==68*5;
PPrinterPos6:==74*5;
PPrinterPos7:==80*5;
PPrinterPos8:==86*5;
PPrinterWindowWidth:==94*5;

LPrinterPos0:==3;
LPrinterPos1:==30*8;
LPrinterPos2:==44*8;
LPrinterPos3:==54*8;
LPrinterPos4:==60*8;
LPrinterPos5:==68*8;
LPrinterPos6:==74*8;
LPrinterPos7:==80*8;
LPrinterPos8:==86*8;
LPrinterWindowWidth:==94*8;

draw_table :: [FormattedProfile] [((a,.Int),(b,.Int))] {#Int} .Int .Int Font *Picture -> *Picture;
draw_table profile area column_positions window_width char_width window_font p
	= p >: SetFont window_font
		>: draw_table_header (2+ascent) (2+line_height) window_width
		>: draw_profile_lines profile (4+ascent+line_height) line_height area;
	{
		line_height=ascent+descent+1;
		(ascent,descent,_,_)=FontMetrics window_font;

		draw_profile_lines function_profiles y line_height area picture
			= draw_profile_lines function_profiles y picture;
			{
				in_area y [((x1,y1),(x2,y2)):areas]
					= (y >= y1-line_height && y <= y2+line_height) || in_area y areas;
				in_area y []
					= False;
				
				draw_profile_lines [] y picture
					= picture;
				draw_profile_lines [{f_module_name,f_function_name,f_time,f_time_percentage,f_n_allocated_bytes,f_alloc_percentage,f_n_strict_calls,f_n_lazy_calls,f_n_curried_calls}:function_profiles] y picture
					| in_area y area
						# picture=picture
							>: draw_string_at (column_positions.[0],y) (if (size f_function_name<=50) f_function_name (f_function_name%(0,47)+++".."))
							>: draw_string_at (column_positions.[1],y) (if (size f_module_name<=30) f_module_name (f_module_name%(0,27)+++".."))
							>: draw_string_at_left (column_positions.[2],y) (format_real 6 1 6 1000000.0 f_time)
							>: draw_string_at_left (column_positions.[3],y) (format_real 2 2 3 1000.0 f_time_percentage)
							>: draw_string_at_left (column_positions.[4],y) (format_string_r 12 (toString f_n_allocated_bytes))
							>: draw_string_at_left (column_positions.[5],y) (format_real 2 2 3 1000.0 (f_alloc_percentage))
							>: draw_string_at_left (column_positions.[6],y) (format_string_r 10 (toString f_n_strict_calls))
							>: draw_string_at_left (column_positions.[7],y) (format_string_r 10 (toString f_n_lazy_calls))
							>: draw_string_at_left (column_positions.[8],y) (format_string_r 10 (toString f_n_curried_calls))
						= draw_profile_lines function_profiles (y+line_height) picture;
						= draw_profile_lines function_profiles (y+line_height) picture;
			}
		
		draw_table_header y line_y window_width picture
			= picture
				>: draw_string_at (column_positions.[0],y) "Function"
				>: draw_string_at (column_positions.[1],y) "Module"
				>: draw_string_at_left (column_positions.[2],y) "      Time(s)"
				>: draw_string_at_left (column_positions.[3],y) "  Time(%)"
				>: draw_string_at_left (column_positions.[4],y) (format_string_r 13 "Alloc(bytes)")
				>: draw_string_at_left (column_positions.[5],y) "  Alloc(%)"
				>: draw_string_at_left (column_positions.[6],y) (format_string_r 13 "Strict(n)")
				>: draw_string_at_left (column_positions.[7],y) (format_string_r 13 "Lazy(n)")
				>: draw_string_at_left (column_positions.[8],y) (format_string_r 13 "Curried(n)")
				>: DrawLine ((0,line_y),(window_width,line_y));

		draw_string_at_left (x,y) s picture
			# (string_width_in_pixels,picture) = PictureStringWidth s picture;
			# position=(x+(size s*char_width-string_width_in_pixels),y);
			= picture >: MovePenTo position >: DrawString s;
	}

:: MPrintSetup = PrintNotSetup | MPrintSetup PrintSetup;

:: *MState = PState ProfileInfo (UpdateFunction MState) MPrintSetup;

:: ProfileInfo = ProfileInfo Bool [FormattedProfile] [FormattedProfile] FormattedProfile | NoProfileInfo;

from deltaDialog import OpenNotice,Notice,NoticeButton;

/*
error_notice strings s io
	# (_,s,io) = OpenNotice (Notice strings (NoticeButton 0 "OK") []) s io;
	= (s,QuitIO io);

error_notice_and_quit strings world
	# (_,world) = StartIO [TimerSystem []] 0 [error_notice strings] world;
	= world;

define_fltused :: !Bool -> Bool;
define_fltused n = code {
	.export _fltused
:_fltused
	pop_b 0
}

measure_clock_speed_and_profile_overhead :: (!Int,!Real,!Real);
measure_clock_speed_and_profile_overhead = code {
	ccall measure_clock_speed_and_profile_overhead ":IRR"
}

clock_speed_and_profile_overhead
	| define_fltused True
		=: measure_clock_speed_and_profile_overhead;

*/

Start world
/*
	# (r,_,_) = clock_speed_and_profile_overhead;
	| r==1
		= error_notice_and_quit
			["Profiling does not work on this computer,",
			 "because the processor does not have a time stamp counter"
			] world;
	| r==2
		= error_notice_and_quit
			["Profiling does not work on this computer,",
			 "because the windows API function QueryPerformanceFrequency failed"
			] world;
*/
	# (aboutdialog,world)	= accFiles (MakeAboutDialog ApplicationName HelpFileName show_help) world
	# (_,world) = let {
		state = PState NoProfileInfo update_function PrintNotSetup;
		update_function=window_update_function monaco9_font;
	  
	  	io_system = [DialogSystem [aboutdialog],
	  					MenuSystem [file_menu,sort_menu,show_menu],
						AppleEventSystem {	openHandler = open_file_function,
											quitHandler= \s io -> (s,QuitIO io),
											scriptHandler = \_ s io -> (s, io),
											clipboardChangedHandler = \s io -> (s, io)}
						];
		file_menu = PullDownMenu 1 "File" Able [
						MenuItem 10 "Open..."               (Key 'O') Able file_open_function,
						MenuItem 11 "Close"                 (Key 'W') Unable file_close_function,
						MenuItem 12 "Print"					(Key 'P') Unable printTable:
						PCorMac file_menu_items_rest [MenuItem 13 "Page Setup.."			NoKey Able page_setup:file_menu_items_rest]];
			file_menu_items_rest =[
						MenuItem 14 "Help"					NoKey Able show_help,
						MenuItem 15 "Quit"                  (Key 'Q') Able (\s io -> (s,QuitIO io))
					];

		sort_menu = PullDownMenu 2 "Sort" Unable [
						MenuItem 20 "Sort by Function"      (Key 'F') Able sort_by_function_name,
						MenuItem 21 "Sort by Module"  	    (Key 'M') Able sort_by_module_name,
						MenuItem 22 "Sort by Time"          (Key 'T') Able sort_by_time_function,
						MenuItem 23 "Sort by Allocation"    (Key 'A') Able sort_by_allocation_function,
						MenuItem 24 "Sort by Strict calls"  (Key 'S') Able sort_by_strict_function,
						MenuItem 25 "Sort by Lazy calls"    (Key 'L') Able sort_by_lazy_function,
						MenuItem 26 "Sort by Curried calls" (Key 'C') Able sort_by_curried_function
					];

		show_menu = PullDownMenu 3 "Show" Unable [
						MenuItem 30 "Show Functions"      NoKey Able show_functions,
						MenuItem 31 "Show Modules"  	  NoKey Able show_modules
					];

		window_update_function window_font area (PState profile=:(ProfileInfo show_functions formatted_profile other_profile total_profile) update_function print_setup)
			= (PState profile update_function print_setup,[draw_table (formatted_profile++[total_profile]) area column_positions WindowWidth 6 window_font]);
			
		column_positions={Pos0,Pos1,Pos2,Pos3,Pos4,Pos5,Pos6,Pos7,Pos8};
	  } in
			StartIO io_system state [] world;
	= world;

file_open_function pstate io
	# (file_selected,file_name,(PState profile update_function print_setup),io) = SelectInputFile pstate io;
		with {
			select_input_file files
				# (file_selected,file_name,files,io)=SelectInputFile files io;
				= ((file_selected,file_name,io),files);
		}
	| file_selected
		= open_file_function file_name (PState profile update_function print_setup) io;
		= (PState profile update_function print_setup,io);

file_close_function (PState profile_info update_function print_setup) io
	# io=io >: DisableMenus [2,3]
			>: DisableMenuItems [11,12]
			>: CloseWindows [0]
			>: EnableMenuItems [10];
	= (PState NoProfileInfo update_function print_setup,io);

open_profile file_name files
	# (open_ok,input_file,files) = fopen file_name FReadText files;
	| not open_ok
		= ((False,[]),files);
		# (profile,input_file)=read_profile input_file;
		  (close_ok,files)=fclose input_file files;
		= ((True,profile),files);

window_height_function ascent descent formatted_profile = 6+(ascent+descent+1)*(2+length formatted_profile);

open_file_function file_name (PState NoProfileInfo update_function print_setup) io
	# ((open_ok,profile),io) = accFiles (open_profile file_name) io;
 	| not open_ok
		= (PState NoProfileInfo update_function print_setup,io);

		# (total_strict_calls,total_lazy_calls,total_curried_calls,total_allocation,total_time) = sum_time_and_allocation profile;

		  module_profile=totals_per_module (sortBy (\ p1 p2 -> p1.module_name<=p2.module_name) profile);
		  (formatted_module_profile,_)=format_profile total_strict_calls total_lazy_calls total_curried_calls total_allocation total_time module_profile;
		  formatted_module_profile=sortBy ge_profile_time formatted_module_profile;

		  (formatted_profile,total_profile)=format_profile total_strict_calls total_lazy_calls total_curried_calls total_allocation total_time profile;
		  formatted_profile=sortBy ge_profile_time formatted_profile;
			  
		  (screen_size_x,screen_size_y)=MaxFixedWindowSize;

		  profile_window = let {
			window_height=window_height_function  ascent descent formatted_profile;
			(ascent,descent,_,_)=FontMetrics monaco9_font;

			window_mouse_function ((x,y),ButtonDown,_) s io
				| y>=0 && y<3+ascent+descent
					| x<Pos1
						= sort_by_function_name s io;
					| x<Pos2
						= sort_by_module_name s io;
					| x<Pos4
						= sort_by_time_function s io;
					| x<Pos6
						= sort_by_allocation_function s io;
					| x<Pos7
						= sort_by_strict_function s io;
					| x<Pos8
						= sort_by_lazy_function s io;
						= sort_by_curried_function s io;
			  window_mouse_function _ s io
					= (s,io);
		  } in
			ScrollWindow 0 ((screen_size_x-WindowWidth)>>1,10) file_name
							(ScrollBar (Thumb 0) (Scroll 4)) (ScrollBar (Thumb 0) (Scroll 4))
							((0,0),(WindowWidth,window_height))
							(100,10) (WindowWidth,if (window_height<=screen_size_y-40) window_height (screen_size_y-40))
							update_function [Mouse Able window_mouse_function,GoAway file_close_function];
		# io=io >: DisableMenuItems [10]
				>: OpenWindows [profile_window]
				>: EnableMenus [2,3]
				>: EnableMenuItems [11,12];
		= (PState (ProfileInfo False formatted_profile formatted_module_profile total_profile) update_function print_setup,io);
open_file_function file_name s=:(PState (ProfileInfo _ _ _ _) _ _) io
	= open_file_function file_name <:: file_close_function s io;

sort_and_redraw_window compare_function (PState (ProfileInfo show_modules formatted_profile other_profile total_profile) update_function print_setup) io
	# formatted_profile=sortBy compare_function formatted_profile;
	= DrawInActiveWindowFrame redraw_window (PState (ProfileInfo show_modules formatted_profile other_profile total_profile) update_function print_setup) io;
{
	redraw_window area s
		# (s,d)=update_function area s;
		= (s,[\picture->foldr EraseRectangle picture area:d]);
}

sort_by_time_function s io
	= sort_and_redraw_window ge_profile_time s io;

sort_by_function_name s io
	= sort_and_redraw_window (\ p1 p2 -> p1.f_function_name<=p2.f_function_name) s io;

sort_by_module_name s io
	= sort_and_redraw_window (\ p1 p2 -> p1.f_module_name<=p2.f_module_name) s io;

sort_by_allocation_function s io
	= sort_and_redraw_window (\ p1 p2 -> p1.f_n_allocated_bytes>=p2.f_n_allocated_bytes) s io;

sort_by_strict_function s io
	= sort_and_redraw_window (\ p1 p2 -> p1.f_n_strict_calls>=p2.f_n_strict_calls) s io;

sort_by_lazy_function s io
	= sort_and_redraw_window (\ p1 p2 -> p1.f_n_lazy_calls>=p2.f_n_lazy_calls) s io;

sort_by_curried_function s io
	= sort_and_redraw_window (\ p1 p2 -> p1.f_n_curried_calls>=p2.f_n_curried_calls) s io;

show_functions :: !*MState *(IOState *MState) -> *(!*MState,!*IOState *MState);
show_functions s=:(PState (ProfileInfo True _ _ _) update_function print_setup) io
	= show_other_profile s io;
show_functions s io
	= (s,io);

show_modules :: !*MState *(IOState *MState) -> *(!*MState,!*IOState *MState);
show_modules s=:(PState (ProfileInfo False _ _ _) update_function print_setup) io
	= show_other_profile s io;
show_modules s io
	= (s,io);

show_other_profile (PState (ProfileInfo show_modules formatted_profile other_profile total_profile) update_function print_setup) io
	# (ascent,descent,_,_)=FontMetrics monaco9_font;
	  window_height=window_height_function ascent descent other_profile;
	  s=PState (ProfileInfo (not show_modules) other_profile formatted_profile total_profile) update_function print_setup;
	  (s,io) = ChangePictureDomain 0 ((0,0),(WindowWidth,window_height)) s io;
	= DrawInActiveWindowFrame redraw_window s io;
	{
		redraw_window area s
			# (s,d)=update_function area s;
			= (s,[\picture->foldr EraseRectangle picture area:d]);
	}

show_help s io
	=	(s, ShowHelp HelpFileName io);

import deltaIOState,deltaDialog;
import deltaPrint;

page_setup (PState pi update_function print_setup) io
	# (print_setup,io) = case print_setup of {
							PrintNotSetup -> defaultPrintSetup io;
							MPrintSetup print_setup -> (print_setup,io);
						};
	# (print_setup,io) = printSetupDialog print_setup io;
	= ((PState pi update_function (MPrintSetup print_setup)),io);

printTable :: *MState *(IOState *MState) -> *(*MState,*IOState *MState);
printTable (PState pi=:(ProfileInfo _ functionData _ sumData) update_function print_setup) io
	# (print_setup,io) = case print_setup of {
							PrintNotSetup -> defaultPrintSetup io;
							MPrintSetup print_setup -> (print_setup,io);
						};
	# s=PState pi update_function (MPrintSetup print_setup);
	# (doesntFit,{s,io}) = print2 True True generate_pages print_setup {s=s, io=io};
	| doesntFit
		# (_,s,io) = OpenNotice (Notice ["The paper is not wide enough to","print all columns.",
										 "Try landscape format."] (NoticeButton 0 "Ok") []) s io;
		= (s,io);
	= (s,io);
	{}{
		column_l_positions={LPrinterPos0,LPrinterPos1,LPrinterPos2,LPrinterPos3,LPrinterPos4,LPrinterPos5,LPrinterPos6,LPrinterPos7,LPrinterPos8};
		column_p_positions={PPrinterPos0,PPrinterPos1,PPrinterPos2,PPrinterPos3,PPrinterPos4,PPrinterPos5,PPrinterPos6,PPrinterPos7,PPrinterPos8};
		
		generate_pages {printSetup,jobInfo={range=(first,last),copies}} picture
			# {page=page=:(maxX,maxY),resolution=(horizontal_dpi,_)} = getPageDimensions printSetup True;
			# landscape = maxX > maxY;
			# printFont = if landscape geneva8_font geneva6_font;
			# (ascent,descent,maxW,_)=FontMetrics printFont;
			# line_height=ascent+descent+1;
			# nrLinesPerPage = (maxY+1)/line_height;
			  pages_without_sum = groupBy (nrLinesPerPage-2) functionData;
			  printed_pages = pages_without_sum % (first-1,last-1);
			| isEmpty printed_pages
				= ([],picture,False);
			// ensure, that sum is always printed, regardless of the range of pages the user has choosen
			# (all_but_last,last_page) = splitAt ((length printed_pages)-1) printed_pages;
			  last_page_1 = (hd last_page) % (0,nrLinesPerPage-3);	// there needs to be place for the sum line
			  new_last_page = last_page_1 ++ [sumData];
			  pages = all_but_last ++ [new_last_page];
			// ok
			# column_positions=if landscape column_l_positions column_p_positions;
			# printer_window_width = if landscape LPrinterWindowWidth PPrinterWindowWidth;
			# char_width = if landscape 5 3;
			
			# printer_window_width=PCorMac (printer_window_width*horizontal_dpi/72) printer_window_width;
			# column_positions = PCorMac {pos*horizontal_dpi/72 \\ pos<-: column_positions} column_positions;
			# char_width = PCorMac (char_width*horizontal_dpi/72) char_width;
			
			# all_drawfuncs
			    = map 
			    	(\lines_in_one_page -> draw_table lines_in_one_page [((0,0),page)] column_positions printer_window_width char_width printFont)
					  pages;
			= (flatten (repeatn copies all_drawfuncs),picture,False);
	};

print2 :: Bool Bool (PrintInfo *Picture -> *([*Picture -> *Picture],*Picture,Bool)) PrintSetup *(PState MState) -> *(!Bool,!*(PState MState));
print2 doDialog emulateScreen generate_pages print_setup ps=:{s,io}
	# (alt,printEnv) = printPagePerPage doDialog emulateScreen 0 initFun stateTransition print_setup
				//{state,io}
				{ps & io=io};
	= case alt of {
			StartedPrinting (_,doesntFit,print_setup)
				# {s=(PState pi update_function _),io}=printEnv;
				-> (doesntFit,{s=PState pi update_function (MPrintSetup print_setup),io=io});
 			Cancelled _
 				-> (False,printEnv);
		};
	{
	  	initFun _ printInfo=:{printSetup} picture
	  		# (drawFuns,picture,doesntFit) = generate_pages printInfo picture;
	  		= ((isEmpty drawFuns,(0,0)), ((drawFuns,doesntFit,print_setup),picture));
	  	
	  	stateTransition (([drawFun:rest],doesntFit,print_setup),picture)
	  		= ((isEmpty rest,(0,0)), ((rest,doesntFit,print_setup), drawFun picture));
	};

groupBy :: !Int [x] -> [[x]];
groupBy n [] = [];
groupBy n l = [take n l  : groupBy n (drop n l)];