request-date.red

Red [
	Title: 		{Request a date}
	Purpose:	{To enter a date using a calendar display}
	Author:		"Rudolf W. MEIJER"
	File:		%request-date.red
	Notes:		{Inspired by the corresponding Rebgui facility}
	Language:	'English
	Tabs:		4
] ; end prologue

;---|----1----|----2----|----3----|----4----|----5----|----6----|----7----|-


context [

;---------------------------------------------------------------------------
; constants
;---------------------------------------------------------------------------

days-names: make block! 7
repeat i 7 [
	insert tail days-names copy/part system/locale/days/:i 2
]
month-names: make block! 12
repeat i 12 [
	insert tail month-names copy/part system/locale/months/:i 3
]

arrow-size: 30x20
txt-size: 70x20

;---------------------------------------------------------------------------
; functions
;---------------------------------------------------------------------------

display-month: func [
	{show month and year}
	date [date!]
][
	month-chosen/text: rejoin [
		pick month-names date/month " " date/year
	]
]
fill-days: func [
	{put the day numbers in the boxes for a given month}
	date [date!]
	/local the-date the-month box-nr i
][
	minical/extra: date
	display-month date
	the-month: date/month
	the-date: make date! reduce [1 the-month date/year]
	box-nr: the-date/weekday
	repeat i 42 [
		clear days/:i/text
		days/:i/color: white
	]
	days/(date/day + box-nr - 1)/color: silver
	while [the-month = date/month][
		days/:box-nr/text: form the-date/day
		the-date: the-date + 1
		the-month: the-date/month
		box-nr: box-nr + 1
	]
]

prev-year: func [
	{display same month in previous year}
][
	fill-days to-date reduce [
		minical/extra/day minical/extra/month minical/extra/year - 1
	]
]

prev-month: func [
	{display previous month in same year}
	/local d
][
	d: minical/extra
	d/month: d/month - 1
	if d/day < minical/extra/day [d: d - d/day]
	fill-days d
]

today: func [
	{display current month}
][
	fill-days now/date
]

next-month: func [
	{display next month in same year}
	/local d
][
	d: minical/extra
	d/month: d/month + 1
	if d/day < minical/extra/day [d: d - d/day]
	fill-days d
]

next-year: func [
	{display same month in next year}
][
	fill-days to-date reduce [
		minical/extra/day minical/extra/month minical/extra/year + 1
	]
]

set-date: func [
	{set date that user clicked}
	day-str [string!]
	/local first-date box-nr
][
	unless empty? day-str [
		first-date: minical/extra
		first-date/day: 1
		box-nr: first-date/weekday
		days/(minical/extra/day + box-nr - 1)/color: white
		minical/extra/day: load day-str
		days/(minical/extra/day + box-nr - 1)/color: silver

	]
]

;---------------------------------------------------------------------------
; window construction
;---------------------------------------------------------------------------

minical-spec: compose [
	title "Request-date"
	month-chosen: text 200x16 center (form now/date)
	return
	button (arrow-size) "<<" [prev-year]
	button (arrow-size) "<"  [prev-month]
	button (txt-size) "Today" [today]
	button (arrow-size) ">"  [next-month]
	button (arrow-size) ">>" [next-year]
	return
	cal: panel 200x200 [
	]
	return
	button (txt-size) "OK" [unview]
	button (txt-size) "Cancel" [minical/extra: none unview]
]

days-boxes: find minical-spec quote cal:
days-boxes: first find days-boxes block!
; first row is for day names
repeat j 7 [
	insert tail days-boxes compose [
		at (as-pair j - 1 * 28 + 4 0) base 25x25 white
	]
]
; next 6 rows are for dates - clickable
repeat i 6 [
	repeat j 7 [
		insert tail days-boxes compose [
			at (as-pair j - 1 * 28 + 4 i * 28) base 25x25 white ""
			[set-date face/text]
		]
	]
	insert tail days-boxes 'return
]

minical: layout/tight minical-spec
repeat i 7 [
	cal/pane/:i/text: days-names/:i
]
days: skip cal/pane 7

;---------------------------------------------------------------------------
; exposed function
;---------------------------------------------------------------------------

set 'request-date func [
	date [date! none!]
][
	either date [fill-days date][today]
	view/flags minical [modal no-buttons]
	minical/extra
]

] ; end context