To pick a date...

date-picker.red

Red [
	Started: 2018-05-16
	Date: 2019-01-25
	Needs: View
	;%range.red ;https://gist.github.com/toomasv/0e3244375afbedce89b3719c8be7eac0
	;TinyURL https://tinyurl.com/y7bt2nqy
	File: %date-picker.red
]
context [
	y: d: none
	c: 0
	years: ["2017" "2018" "2019" "2020" "2021" "2022"]
	dates: copy []
	boxes: copy [
		origin 2x2 space 2x2 
		style d: box 32x25 font [style: 'bold color: snow]
		d "Mo" d "Tu" d "We" d "Th" d "Fr" d "Sa" d "Su" return
		style b: box 32x32 font [color: water] snow [
			attempt [sel/color: col] col: face/color sel: face sel/color: orange probe face/extra
		]
	]
	do https://tinyurl.com/y7bt2nqy ;%range.red ;
	sel: col: none
	tmp: copy []
	today: now/date
	add-dates: func [dates /shade][
		collect/into [
			foreach i dates [
				c: c + 1
				keep compose/deep [
					b (form i/4) (either shade ['silver][either i = today ['wheat][]]) with [extra: (i)] (either i/10 = 7 ['return][])
				]
			]
		] clear tmp
		tmp
	]
	view lay: layout compose/only [
		year: drop-down data (years) select (index? find years form pick now/date 2) 61x23 on-change [
			do-actor month event 'change
		]
		button 23x23 "<" [
			month/selected: either 1 = month/selected [year/selected: year/selected - 1 12][month/selected - 1] 
			do-actor month event 'change
		]
		month: drop-list data (system/locale/months) select (pick now/date 3) [
			y: any [attempt [load year/text] pick now/date 2]
			d: (make date! reduce [
				either month/selected = 12 [y + 1][y]
				month/selected % 12 + 1
				1
			]) - 1
			dates: range d - d/day + 1 d
			collect/into [
				j: pick dates/1 10
				keep add-dates/shade range dates/1 - (pick reduce [8 j] j = 1) + 1 dates/1 - 1
				keep add-dates dates 
				keep add-dates/shade range/limit i + 1 42 - c
				c: 0
			] clear at boxes 34
			cal/pane: layout/only boxes
		] on-create [do-actor face event 'change]
		button 23x23 ">" [
			month/selected: either 12 = month/selected [year/selected: year/selected + 1 1][month/selected + 1] 
			do-actor month event 'change
		] return
		cal: panel water 240x233 
	]
]