REBOL [ Title: "Calendar and Scheduler" Date: 4-Jun-2001/10:20 Version: 1.0.7 ;; correct format problem -- see discussion thread for details File: %calendar.r Author: "Sterling Newton" Purpose: "A simple calendar application." Email: %sterling--rebol--com ] cal-ctx: context [ cal-data: either exists? %cal-sched.r [load %cal-sched.r] [copy []] cur-day-data: none sub-face: cal-face: dx: dy: size-hol: size-list: csize: cell-size: new-event?: none save-data: does [save %cal-sched.r cal-data] base-size: 567x446 size-num: 20x16 do set-base-sizes: does [ dx: dy: to-integer base-size/x / 7 size-hol: to-pair reduce [max dx - 20 0 16] size-list: to-pair reduce [dx max dx - 16 0] csize: dx cell-size: to-pair reduce [csize csize] ] base: now/date base/day: 1 md: func [date] [join pick system/locale/months date/month [" " date/year]] update-cal: does [ month/text: md base show cal-face ] sdaypan: [tmp: base if sub-num/text [tmp/day: sub-num/text show-day tmp]] sub-face: do sub-face-def: has [lay] [ lay: layout [ origin 0x0 space 0x0 across sub-num: box bold size-num white font [size: 10 color: black style: none shadow: off] edge [size: 1x1] sdaypan sub-hol: text size-hol white font-size 10 sdaypan return sub-list: list size-list [ across space 0x0 tinfo: txt (to-pair reduce [csize 20]) font-size (to-integer csize / 10 + 1) ] supply [ either tmp: find cal-data sub-list/date [ tmp: tmp/2 count: count + sub-list/oset * 2 if count > length? tmp [face/show?: false exit] face/show?: true tinfo/text: get-ev-item tmp count info ] [face/show?: false exit] ] with [date: none oset: 0 action: sdaypan] at (cell-size - 8x16) ; panel [origin 0x0 space 0x0 below ; sub-au: arrow up 8x8 ; sub-ad: arrow down 8x8] ] lay/feel: make face/feel [ detect: func [face act] [if act/type = 'down sdaypan act] ] lay ] pane-func: func [face oset /bas] [ if pair? oset [return ((to-integer oset/y / csize) * 7) + to-integer (oset/x / csize) + 1] if any [none? oset oset > 42] [return none] sub-face/offset: to-pair reduce [(oset - 1) // 7 * csize (to-integer (oset - 1) / 7) * csize] bas: base either any [oset < bas/weekday (pick bas + oset - bas/weekday 2) <> base/month] [ sub-num/text: none sub-num/color: gray sub-hol/color: gray sub-list/color: gray sub-list/date: bas + (oset - bas/weekday) ] [ sub-num/text: bas/day + (oset - bas/weekday) sub-num/color: white sub-hol/color: base-color sub-list/color: white sub-list/date: bas + sub-num/text - 1 ] sub-face ] iter-pane: make face [ size: to-pair reduce [csize * 7 csize * 6] pane: :pane-func edge: none ] cal-face-def: does [layout [ origin 0x0 space 0x0 across al: arrow left [any [positive? base/month: base/month - 1 base/month: 12] update-cal] month: box 100.0.0 md base (to-pair reduce [7 * csize - (csize) to-integer csize / 2]) ar: arrow right [any [13 > base/month: base/month + 1 base/month: 1] update-cal] ]] cal-face: do cal-face-def do set-main-info: does [ sub-face: do sub-face-def sub-face/edge/size: 1x1 sub-face/edge/color: black al/size: ar/size: 32x32 month/size: (to-pair reduce [7 * csize - (2 * 32) - 2 32]) month/offset: 1x0 * al/size/x ar/offset/x: al/size/x + month/size/x cal-face/size: to-pair reduce [7 * csize 6 * csize + 32] iter-pane/offset: 0x32 iter-pane/size: 7x6 + to-pair reduce [csize * 7 csize * 6 + 32] ] append cal-face/pane iter-pane do-resize: does [ set-base-sizes set-main-info show cal-face ] show-day: func [day] [ dp-day/data: day dp-day/text: rejoin [pick system/locale/days day/weekday ", " day] if none? cur-day-data: find cal-data day [cur-day-data: copy []] if not empty? cur-day-data [cur-day-data: cur-day-data/2] either find system/view/screen-face/pane day-plan [ show day-plan] [ view/new day-plan] ] get-ev-item: func [list count 'word] [ select pick list count word ] day-plan: layout [ across dp-al: arrow left [show-day dp-day/data - 1] dp-day: h1 280x30 center font-size 18 dp-ar: arrow right [show-day dp-day/data + 1] return dp-hol: text 300x16 black return m1: at dp-list: list 320x450 [ space 0x0 across dp-from: txt black ivory 50x20 dp-info: txt black ivory 270x20 [ if dp-area/ff [ either tmp: find cur-day-data dp-area/time [ change/only next tmp compose [info (dp-area/text)] ] [ append cur-day-data compose/deep [(dp-area/time) [info (dp-area/text)]] ] ] if all [empty? dp-area/text tmp: find cur-day-data dp-area/time] [remove/part tmp 2] either all [cur-day-data tmp: find/tail cal-data dp-day/data] [ change/only tmp cur-day-data ] [ if not empty? cur-day-data [ append cal-data compose/deep [(dp-area/day) [(cur-day-data)]]] ] dp-area/ff: dp-info dp-area/day: dp-day/data dp-area/time: dp-from/text dp-area/offset: dp-list/offset + (0x22 * (dp-info/data - dp-list/oset)) + 50x0 + dp-list/edge/size dp-area/text: dp-info/text focus dp-area show [dp-area dp-list cal-face] ] font [colors: reduce [black black]] return box black 320x2 ] supply [ count: count + dp-list/oset if count > 48 [face/show?: false exit] face/show?: true dp-from/text: 0:30 * (count - 1) either tmp: find cur-day-data dp-from/text [ dp-info/text: get-ev-item tmp 2 info ] [dp-info/text: none] dp-info/data: count - 1 ] with [oset: 16 lc: to-integer 450 / 22] at m1 + 320x0 dp-sld: slider 16x450 [ dp-list/oset: to-integer (48 - dp-list/lc * dp-sld/data) show dp-list ] return button "Close" [ if dp-area/ff [dp-area/ff/action dp-area/ff none] save-data hide dp-area unview/only day-plan ] at m1 + (0x1 * dp-list/size / 2) at m1 dp-area: area (dp-info/size - 4x0) ivory ivory edge [size: 0x0] with [show?: false ff: day: time: none] ] dp-sld/redrag dp-list/lc / (48 - dp-list/lc) dp-sld/data: 16 / (48 - dp-list/lc) event-lay: layout [ across txt 37x24 middle bold "Start" ev-start: field 50 "8:00" ;ev-sampm: txt 20 "am" txt 37x24 middle bold "End" ev-end: field 50 "9:00" return ;ev-sampm: txt 20 "am" return ev-text: area 250x60 return button "Done" [ dat: compose/deep [(ev-start/text) [end (ev-end/text) info (ev-text/text)]] either tmp: select cal-data dp-day/data [ append tmp dat ] [ append cal-data compose/deep [(dp-day/data) [(dat)]] ] save-data hide-popup show-day dp-day/data show cal-face ] button coal "Cancel" [unview/only event-lay] ] insert-event-func [ if event/type = 'resize [ base-size: cal-face/size do-resize return true ] event ] view/options cal-face [resize] ]