REBOL [
	title: "request-date object/func optimization and enhancment"
	file: %request-date.r
	Author: "Didier Cadieu"
	email: to-email rejoin ["Didec" #"@" "wanadoo.fr"]	; (f.ck the bot)
	date: 23-dec-2003
	version: 1.1
	purpose: {
		This is an enhanced replacement for the original request-date function,
		the embedded date picker in view (datepicker).
		
		- Clean, correct and optimize the code.
		- add day names at top of window (use system/locales/days).
		- add first-day-of-week value to choose starting with Sunday
		  or Monday.
		  (I think this value should be part of system/locales)
		- add Today button at bottom.
		- Today is shown with red circle in calendar.
		
		- New refinment:  'request-date/date a-date  to initialize the calendar.
		  This date is shown with red square in calendar, and is
		  retuned instead of none if the window is closed.
		  
		WARNING ! It needs View 1.2.8+ to work
	}
	
	library: [
		level: 'advanced
		platform: 'all
		type: [function module tool demo]
		domain: [gui patch ui]
		tested-under: [View 1.2.8 on [win2k winXP] View 1.2.41 on [Win2k WinXP]]
		support: none
		license: 'public-domain
		see-also: none
	]
]

;***** MOD function will be included in View 1.3
; Here is a quick define for older version
if not value? 'mod [mod: func [a b][a // b]]


req-funcs: make req-funcs [
	req-date: make object! [
		base: date-lay: last-f: mo-box: today-draw: this-draw: result: none
		cell-size: 24x24

		; NEW WORD: DETERMINE FIRST DAY OF WEEK (1=monday or 7=sunday)
		; THE BETTER WILL BE TO ADD THIS WORD TO system/locales
		; IT COULD BE INITIALIZE ACCORDING TO THE O.S. VALUE (if possible).
		first-day-of-week: 7
		
		; THE COMPUTATION WAS CHANGED TO MANAGE FIRST-DAY-OF-WEEK
		; AND AVOID HAVING AN EMPTY FIRST LINE
		calc-month: func [/local month bas tod d][
			bas: base
			month: bas/month
			bas/day: 1
			bas: bas - (mod bas/weekday 14 - first-day-of-week) + mod first-day-of-week 7
			tod: now/date
			foreach face skip date-lay/pane 11 [
				either bas/month <> month [face/text: none] [
					face/text: bas/day
					d: copy either bas = tod [today-draw][[]]
					if bas = result [append d this-draw]
					face/effect: compose/only [draw (d)]
				]
				bas: bas + 1
			]
			mo-box/text: md base
			show [date-lay mo-box]
		]

		md: func [date][join pick system/locale/months date/month [" " date/year]]

		init: func [/local cell-feel offs fon cs2][
			if none? base [base: now/date]
			fon: make face/font [valign: 'middle align: 'center]
			cell-feel: make face/feel [
				over: func [f a] [
					f/color: either all [a f/text] [yellow] [f/color2]
					show f
				] 
				engage: func [f a e] [
					if all [a = 'down f/text] [
						either f/data [base: f/data][base/day: f/text]
						f/color: f/color2 result: base hide-popup
					]
				]
			]
			
			cs2: cell-size  / 2
			today-draw: reduce ['pen red 'circle cs2 - 1 cs2/x - 3 'circle cs2 cs2/x - 3]
			this-draw: reduce ['pen red 'box 1x1 cell-size - 2x2]
			
			date-lay: layout [
				size cell-size * 7x9
				origin 0x0 space 0
				across
				arrow left cell-size [base/month: base/month - 1 calc-month]
				mo-box: box cell-size * 5x1 md base font [size: 12]
				arrow right cell-size [base/month: base/month + 1 calc-month]
				return
				offs: at
				at cell-size * 0x8
				box rejoin ["Today: " now/date] cell-size * 7x1 with [
					color2: color font: fon 
					effect: compose/only [draw (today-draw)] feel: cell-feel
					data: now/date
				]
			]

			last-f: func [num][
				append date-lay/pane make face [
					offset: offs size: cell-size feel: edge: none
					text: copy/part pick system/locale/days num 2
				]
				offs/x: offs/x + cell-size/x
			]
			last-f first-day-of-week
			repeat slot 6 [last-f first-day-of-week // 7 + slot 2]
			offs: offs + cell-size * 0x1
			
			last-f: none
			repeat slot 42 [
				append date-lay/pane make face [
					offset: offs size: cell-size color: color2: white
					font: fon feel: cell-feel data: edge: none
				]
				offs/x: offs/x + cell-size/x
				if zero? slot // 7 [offs: offs + cell-size * 0x1]
			]
			calc-month
		]

		set 'request-date func [
			"Requests a date."
			/date dat [date!] "Initial date to show"
			/offset xy [pair!]
		][
			; ON CLOSE WITHOUT SELECTION, IF /DATE, RETURN "DAT" ELSE RETURN NONE
			base: any [result: either date [dat][none] now/date]
			either none? date-lay [init][calc-month]
			either offset [inform/offset date-lay xy] [inform date-lay]
			result
		]
	]
]


;***************** TEST-CODE ******************
; Delete from here to end to use in your own script

sl-en: make system/locale []

sl-fr: make system/locale [
	months: [
		"Janvier" "Février" "Mars" "Avril" "Mai" "Juin"
		"Juillet" "Août" "Septembre" "Octobre" "Novembre" "Décembre"
	]
	days: [
		"Lundi" "Mardi" "Mercredi" "Jeudi" "Vendredi" "Samedi" "Dimanche"
	]
]

view layout [
	style tx text 100 right
	vh3 "Test request-date"
	across

	tx "Locales:"
	rotary "English" "French" [
		system/locale: select reduce ["English" sl-en "French" sl-fr] face/text
		; Reinitialize the layout
		req-funcs/req-date/date-lay: none
	] return

	tx "First day of week:"
	rotary "Sunday" "Monday" [
		req-funcs/req-date/first-day-of-week: select ["Sunday" 7 "Monday" 1] face/text
		; Reinitialize the layout
		req-funcs/req-date/date-lay: none
	] return
	
	button 208 "Request-date" [f-r/text: form request-date show f-r] return
	button 208 "Request-date/date result" [
		if any [empty? f-r/text "none" = f-r/text] [f-r/text: now/date]
		f-r/text: to string!  request-date/date to date! f-r/text
		show f-r
	] return
	tx "Result:" f-r: field 100
]