Skip to content

Instantly share code, notes, and snippets.

@endo64
Forked from meijeru/request-date.red
Created May 18, 2019 08:29
Show Gist options
  • Save endo64/fe17055164843362bb36c6e4f40cb9b3 to your computer and use it in GitHub Desktop.
Save endo64/fe17055164843362bb36c6e4f40cb9b3 to your computer and use it in GitHub Desktop.
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment