A new version of MorphicExtras was added to project The Inbox:
http://source.squeak.org/inbox/MorphicExtras-hjh.106.mcz ==================== Summary ==================== Name: MorphicExtras-hjh.106 Author: hjh Time: 21 January 2013, 6:18:34.106 am UUID: 16ee4f0e-5230-1948-939e-4648fa9f5501 Ancestors: MorphicExtras-bf.104 CalendarChooserMorph by Jon Hylands <[hidden email]> http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20111103/fb5cbdc0/MorphicExtras-CalendarChooser.obj Updated #date accessor method to initialize. =============== Diff against MorphicExtras-bf.104 =============== Item was changed: SystemOrganization addCategory: #'MorphicExtras-Demo'! SystemOrganization addCategory: #'MorphicExtras-AdditionalSupport'! SystemOrganization addCategory: #'MorphicExtras-AdditionalMorphs'! SystemOrganization addCategory: #'MorphicExtras-Widgets'! SystemOrganization addCategory: #'MorphicExtras-Books'! SystemOrganization addCategory: #'MorphicExtras-Postscript Filters'! SystemOrganization addCategory: #'MorphicExtras-Support'! SystemOrganization addCategory: #'MorphicExtras-SoundInterface'! SystemOrganization addCategory: #'MorphicExtras-Undo'! SystemOrganization addCategory: #'MorphicExtras-Postscript Canvases'! SystemOrganization addCategory: #'MorphicExtras-PartsBin'! SystemOrganization addCategory: #'MorphicExtras-AdditionalWidgets'! SystemOrganization addCategory: #'MorphicExtras-Flaps'! SystemOrganization addCategory: #'MorphicExtras-Navigators'! SystemOrganization addCategory: #'MorphicExtras-GeeMail'! SystemOrganization addCategory: #'MorphicExtras-Palettes'! SystemOrganization addCategory: #'MorphicExtras-Leds'! SystemOrganization addCategory: #'MorphicExtras-SqueakPage'! SystemOrganization addCategory: #'MorphicExtras-Text Support'! SystemOrganization addCategory: #'MorphicExtras-Obsolete'! SystemOrganization addCategory: #'MorphicExtras-EToy-Download'! + SystemOrganization addCategory: #'MorphicExtras-CalendarChooser'! Item was added: + Object subclass: #CalendarChooserDay + instanceVariableNames: 'date bounds owner highlighted' + classVariableNames: '' + poolDictionaries: '' + category: 'MorphicExtras-CalendarChooser'! + + !CalendarChooserDay commentStamp: 'Jon 11/2/2011 21:22' prior: 0! + A CalendarChooserDay represents a specific day on a monthly calendar. + + Instance Variables + bounds: <Rectangle> + date: <Date> + highlighted: <Boolean> + owner: <CalendarChooserMorph> + + bounds + - owner-relative bounding box + + date + - the specific date (year/month/day) the CalendarChooserDay represents + + highlighted + - flag to keep track of when a CalendarChooserDay has the mouse dragging over it, and is thus highlighted + + owner + - the morph that contains the CalendarChooserDay, and all its siblings + ! Item was added: + ----- Method: CalendarChooserDay class>>on:for: (in category 'instance creation') ----- + on: aDate for: aCalendarChooserMorph + + ^self new + date: aDate; + owner: aCalendarChooserMorph; + yourself. + ! Item was added: + ----- Method: CalendarChooserDay>>bounds (in category 'accessing') ----- + bounds + + ^ bounds! Item was added: + ----- Method: CalendarChooserDay>>bounds: (in category 'accessing') ----- + bounds: aRectangle + + bounds := aRectangle! Item was added: + ----- Method: CalendarChooserDay>>date (in category 'accessing') ----- + date + + ^ date! Item was added: + ----- Method: CalendarChooserDay>>date: (in category 'accessing') ----- + date: aDate + + date := aDate. + ! Item was added: + ----- Method: CalendarChooserDay>>debugPrint (in category 'printing') ----- + debugPrint + + ^(WriteStream on: (String new: 10)) + print: self class; + nextPutAll: ' ('; + print: self date; + nextPutAll: ' - '; + print: self bounds; + nextPut: $); + contents! Item was added: + ----- Method: CalendarChooserDay>>drawOn:offset: (in category 'drawing') ----- + drawOn: aCanvas offset: origin + + | box dayString textColor textTopLeft textWidth today | + dayString := date dayOfMonth printString. + textWidth := owner weekdayFont widthOfString: dayString. + textTopLeft := bounds topCenter translateBy: (textWidth // -2) @ 3. + box := ((textTopLeft extent: textWidth @ owner weekdayFont height) insetBy: -8 @ -1) translateBy: origin. + today := date = Date today. + textColor := date month = owner date month + ifTrue: [Color black] + ifFalse: [Color veryLightGray]. + (date = owner date or: [self highlighted]) + ifTrue: [ + | lineColor fillColor | + lineColor := today + ifTrue: [Color red] + ifFalse: [Color veryLightGray]. + fillColor := self highlighted + ifTrue: [Color veryVeryLightGray] + ifFalse: [Color veryLightGray]. + aCanvas fillOval: box color: fillColor borderWidth: 1 borderColor: lineColor]. + today & (date ~= owner date) & self highlighted not + ifTrue: [aCanvas fillOval: box color: Color white borderWidth: 1 borderColor: Color red]. + aCanvas + drawString: dayString + at: textTopLeft + origin + font: owner weekdayFont + color: textColor.! Item was added: + ----- Method: CalendarChooserDay>>highlighted (in category 'accessing') ----- + highlighted + + ^highlighted! Item was added: + ----- Method: CalendarChooserDay>>highlighted: (in category 'accessing') ----- + highlighted: aBoolean + + highlighted := aBoolean! Item was added: + ----- Method: CalendarChooserDay>>initialize (in category 'initializing') ----- + initialize + + self highlighted: false! Item was added: + ----- Method: CalendarChooserDay>>owner (in category 'accessing') ----- + owner + + ^ owner! Item was added: + ----- Method: CalendarChooserDay>>owner: (in category 'accessing') ----- + owner: aCalendarChooserMorph + + owner := aCalendarChooserMorph! Item was added: + ----- Method: CalendarChooserDay>>printOn: (in category 'printing') ----- + printOn: aStream + + aStream + print: self class; + nextPutAll: ' ('; + print: self date; + nextPut: $)! Item was added: + BorderedMorph subclass: #CalendarChooserMorph + instanceVariableNames: 'date days touchPoints' + classVariableNames: '' + poolDictionaries: '' + category: 'MorphicExtras-CalendarChooser'! + + !CalendarChooserMorph commentStamp: 'Jon 11/2/2011 21:24' prior: 0! + A CalendarChooserMorph is a standalone morph that represents a selectable monthly calendar. + + Instance Variables + date: <Date> + days: <OrderedCollection of: <CalendarChooserDay>> + touchPoints: <Dictionary key: <Rectangle> value: <Symbol>> + + date + - the currently selected date (always within the current month) + + days + - all the days that are visible, including days from the previous month, the current month, and the next month + + touchPoints + - extra hotspots that are touch-responsive (key rectangle is in world coordinates) + ! Item was added: + ----- Method: CalendarChooserMorph class>>on: (in category 'instance creation') ----- + on: aDate + + ^self new + "extent: 200 @ 160;" + date: aDate; + yourself. + ! Item was added: + ----- Method: CalendarChooserMorph class>>openOn: (in category 'instance creation') ----- + openOn: aDate + + ^(self on: aDate) openInWorld! Item was added: + ----- Method: CalendarChooserMorph>>computeDays (in category 'private') ----- + computeDays + "Populate the days instance variable with CalendarChooserDay instances for the receiver's month." + + | cellHeight cellWidth height topLeft lastMonth nextMonth theDay thisMonth | + topLeft := 0 @ 25. + height := self bounds height - 25. + cellHeight := height // 8. + height := height - cellHeight. + cellWidth := self bounds width // 7. + lastMonth := date month previous. + thisMonth := date month. + nextMonth := date month next. + days := OrderedCollection new. + 1 to: 6 do: [:lineIndex | + | yOffset | + yOffset := topLeft y + (lineIndex * cellHeight). + (self daysForLine: lineIndex) withIndexDo: [:day :dayIndex | + | cellPosX dayDate | + dayDate := thisMonth asDate addDays: day - 1. + (lineIndex = 1 and: [day > 7]) + ifTrue: [dayDate := lastMonth asDate addDays: day - 1]. + (lineIndex > 4 and: [day < 15]) + ifTrue: [dayDate := nextMonth asDate addDays: day - 1]. + cellPosX := cellWidth * (dayIndex - 1). + days add: (theDay := CalendarChooserDay on: dayDate for: self). + theDay bounds: (cellPosX @ yOffset extent: cellWidth @ cellHeight)]]! Item was added: + ----- Method: CalendarChooserMorph>>date (in category 'accessing') ----- + date + + date isNil ifTrue: [ self date: Date today]. + ^date! Item was added: + ----- Method: CalendarChooserMorph>>date: (in category 'accessing') ----- + date: aDate + + | recompute | + recompute := date isNil or: [date month ~= aDate month]. + date := aDate. + recompute + ifTrue: [self computeDays]! Item was added: + ----- Method: CalendarChooserMorph>>daysForLine: (in category 'private') ----- + daysForLine: aNumber + "Return an array of numbers that correspond to the day-of-month numbers of the given line (row) + in the calendar for the month of the receiver's date." + + | dayCount firstWeekday previousDayCount previousMonthDays lastDay | + dayCount := date month daysInMonth. + firstWeekday := Date firstWeekdayOfMonth: date monthIndex year: date year. + previousDayCount := date month previous daysInMonth. + "First case - handle the first line specially" + aNumber = 1 + ifTrue: [ + "If this month's first day is Sunday, the first line is the last week from last month" + firstWeekday = 1 + ifTrue: [^(previousDayCount - 6 to: previousDayCount) asArray]. + + "Otherwise, its a mix of last month and this month" + previousMonthDays := (firstWeekday - 1 to: 1 by: -1) collect: [:each | previousDayCount - each + 1]. + ^previousMonthDays, ((1 to: 7) asArray copyFrom: 1 to: 7 - previousMonthDays size)]. + + "Recompute the last day from the previous line (I love recursion)" + lastDay := (self daysForLine: aNumber - 1) last. + "Second case - the first week of this month starts on Sunday" + (aNumber = 2 and: [lastDay = previousDayCount]) + ifTrue: [^(1 to: 7) asArray]. + + "Third case - the first week of next month starts on Sunday" + lastDay = dayCount + ifTrue: [^(1 to: 7) asArray]. + + "Fourth case - everything else" + ^(lastDay + 1 to: lastDay + 7) collect: [:each | + each <= dayCount + ifTrue: [each] + ifFalse: [each - dayCount]]! Item was added: + ----- Method: CalendarChooserMorph>>defaultBounds (in category 'initializing') ----- + defaultBounds + "Answer the default bounds for the receiver." + + ^0 @ 0 corner: 200 @ 160! Item was added: + ----- Method: CalendarChooserMorph>>drawDaysOn: (in category 'drawing') ----- + drawDaysOn: aCanvas + + days do: [:each | + each + drawOn: aCanvas + offset: self bounds topLeft]! Item was added: + ----- Method: CalendarChooserMorph>>drawMonthHeaderOn: (in category 'drawing') ----- + drawMonthHeaderOn: aCanvas + + | headerWidth headerString box textBox textTopLeft monthBox monthNameWidth yearBox previousMonthBox nextMonthBox | + headerString := self date asMonth printString. + headerWidth := self monthNameFont widthOfString: headerString. + box := self bounds topLeft extent: self bounds width @ 23. + textTopLeft := self bounds topCenter translateBy: (headerWidth // -2) @ 5. + textBox := textTopLeft extent: headerWidth @ self monthNameFont height. + monthNameWidth := self monthNameFont widthOfString: self date monthName, ' '. + monthBox := textBox topLeft extent: monthNameWidth @ textBox height. + yearBox := monthBox topRight corner: textBox bottomRight. + previousMonthBox := (self bounds topLeft translateBy: 10 @ 5) extent: 10 @ self monthNameFont height. + nextMonthBox := (self bounds topRight translateBy: -20 @ 5) extent: 10 @ self monthNameFont height. + touchPoints + at: monthBox put: #handleMonthNameTouched; + at: yearBox put: #handleYearTouched; + at: (previousMonthBox expandBy: 10 @ 5) put: #handlePreviousMonthTouched; + at: (nextMonthBox expandBy: 10 @ 5) put: #handleNextMonthTouched. + aCanvas + frameAndFillRectangle: box + fillColor: Color veryLightGray + borderWidth: 1 + borderColor: Color black; + + line: box bottomLeft + to: box bottomRight + width: 2 + color: Color black; + + drawString: '<' + at: previousMonthBox origin + font: self monthNameFont + color: Color black; + + drawString: '>' + at: nextMonthBox origin + font: self monthNameFont + color: Color black; + + drawString: headerString + at: (self bounds topCenter translateBy: (headerWidth // -2) @ 5) + font: self monthNameFont + color: Color black. + ! Item was added: + ----- Method: CalendarChooserMorph>>drawOn: (in category 'drawing') ----- + drawOn: aCanvas + + touchPoints := Dictionary new. + aCanvas + clipBy: self bounds + during: [:clippedCanvas | + clippedCanvas + fillRectangle: self bounds + color: Color white. + + self + drawMonthHeaderOn: clippedCanvas; + drawWeekDayNamesOn: clippedCanvas; + drawDaysOn: clippedCanvas; + drawTodayOn: aCanvas. + + clippedCanvas + frameRectangle: self bounds + width: 1 + color: Color black]. + + + + ! Item was added: + ----- Method: CalendarChooserMorph>>drawTodayOn: (in category 'drawing') ----- + drawTodayOn: aCanvas + + | text textHeight textTopLeft textWidth textBox | + text := 'Today: ', (Date today printFormat: #(2 1 3 $ 3 1 1)). + textWidth := self weekdayFont widthOfString: text. + textHeight := self weekdayFont height. + textTopLeft := self bounds bottomCenter translateBy: (textWidth // -2) @ (textHeight negated - 5). + textBox := textTopLeft extent: textWidth @ textHeight. + touchPoints at: textBox put: #handleTodayTouched. + aCanvas + drawString: text + at: textTopLeft + font: self weekdayFont + color: Color gray! Item was added: + ----- Method: CalendarChooserMorph>>drawWeekDayNamesOn: (in category 'drawing') ----- + drawWeekDayNamesOn: aCanvas + + | cellHeight height topLeft topRight cellWidth | + topLeft := self bounds topLeft translateBy: 0 @ 25. + topRight := self bounds topRight translateBy: 0 @ 25. + height := self bounds height - 25. + cellHeight := height // 8. + cellWidth := self bounds width // 7. + aCanvas + line: (topLeft translateBy: 0 @ cellHeight) + to: (topRight translateBy: 0 @ cellHeight) + width: 1 + color: Color black. + + #('Sun' 'Mon' 'Tue' 'Wed' 'Thu' 'Fri' 'Sat') withIndexDo: [:dayName :dayIndex | + | cellPosX cellTopCenter textWidth | + cellPosX := cellWidth * (dayIndex - 1). + cellTopCenter := topLeft translateBy: ((cellPosX + (cellWidth // 2)) + 1) @ 0. + textWidth := self weekdayFont widthOfString: dayName. + aCanvas + drawString: dayName + at: (cellTopCenter translateBy: (textWidth // -2) @ 3) + font: self weekdayFont + color: Color darkGray] + ! Item was added: + ----- Method: CalendarChooserMorph>>extent: (in category 'accessing') ----- + extent: aPoint + "Since the day objects cache their bounding box, we have to recompute them if the receiver resizes." + + | result | + result := super extent: aPoint. + date notNil + ifTrue: [self computeDays]. + ^result! Item was added: + ----- Method: CalendarChooserMorph>>handleMonthNameTouched (in category 'event handling') ----- + handleMonthNameTouched + + | newMonthName dayCount | + newMonthName := ListChooser + chooseItemFrom: #('January' 'February' 'March' 'April' 'May' 'June' 'July' + 'August' 'September' 'October' 'November' 'December') + title: 'Choose a month:'. + + newMonthName isNil + ifTrue: [^self]. + + dayCount := (Month month: newMonthName year: date year) daysInMonth. + self date: (Date newDay: (date dayOfMonth min: dayCount) month: newMonthName year: date year). + self changed. + ! Item was added: + ----- Method: CalendarChooserMorph>>handleNextMonthTouched (in category 'event handling') ----- + handleNextMonthTouched + + self date: (date addMonths: 1). + self changed. + ! Item was added: + ----- Method: CalendarChooserMorph>>handlePreviousMonthTouched (in category 'event handling') ----- + handlePreviousMonthTouched + + self date: (date addMonths: -1). + self changed. + ! Item was added: + ----- Method: CalendarChooserMorph>>handleTodayTouched (in category 'event handling') ----- + handleTodayTouched + + self date: Date today. + self changed. + ! Item was added: + ----- Method: CalendarChooserMorph>>handleYearTouched (in category 'event handling') ----- + handleYearTouched + + | newYear dayCount | + newYear := ListChooser + chooseItemFrom: ((2000 to: 2020) collect: [:each | each printString]) + title: 'Choose a year:' + addAllowed: true. + + newYear isNil + ifTrue: [^self]. + + newYear := newYear asNumber. + dayCount := (Month month: date monthIndex year: newYear) daysInMonth. + self date: (Date newDay: (date dayOfMonth min: dayCount) month: date monthIndex year: newYear). + self changed.! Item was added: + ----- Method: CalendarChooserMorph>>handlesMouseDown: (in category 'event handling') ----- + handlesMouseDown: event + + ^true! Item was added: + ----- Method: CalendarChooserMorph>>initialize (in category 'initializing') ----- + initialize + + super initialize. + touchPoints := Dictionary new. + ! Item was added: + ----- Method: CalendarChooserMorph>>monthNameFont (in category 'accessing') ----- + monthNameFont + + ^TTCFont familyName: 'BitstreamVeraSans' pointSize: 11 emphasis: 3! Item was added: + ----- Method: CalendarChooserMorph>>mouseDown: (in category 'event handling') ----- + mouseDown: event + "Handle mouse down and mouse movement. Highlight the day under the mouse." + + | morphRelativeHitPoint | + morphRelativeHitPoint := event cursorPoint translateBy: bounds origin negated. + days do: [:each | + each highlighted: (each bounds containsPoint: morphRelativeHitPoint)]. + self changed. + ! Item was added: + ----- Method: CalendarChooserMorph>>mouseMove: (in category 'event handling') ----- + mouseMove: event + + self mouseDown: event! Item was added: + ----- Method: CalendarChooserMorph>>mouseUp: (in category 'event handling') ----- + mouseUp: event + "Check for hotspot hits - handle them if they match. + Otherwise, convert the event cursor to morph-local, and find the day under it. + If there is nothing under the mouse when it goes up, nothing happens." + + | morphRelativeHitPoint | + touchPoints keysAndValuesDo: [:eachBox :eachSelector | + (eachBox containsPoint: event cursorPoint) + ifTrue: [self perform: eachSelector]]. + morphRelativeHitPoint := event cursorPoint translateBy: bounds origin negated. + days do: [:each | + each highlighted: false. + (each bounds containsPoint: morphRelativeHitPoint) + ifTrue: [self date: each date]]. + self changed. + ! Item was added: + ----- Method: CalendarChooserMorph>>weekdayFont (in category 'accessing') ----- + weekdayFont + + ^TTCFont familyName: 'BitstreamVeraSans' pointSize: 10 emphasis: 0! |
If this were in the image, I'd love to use it to improve Maui's own
date picker. +1. On Mon, Jan 21, 2013 at 12:19 AM, <[hidden email]> wrote: > A new version of MorphicExtras was added to project The Inbox: > http://source.squeak.org/inbox/MorphicExtras-hjh.106.mcz > > ==================== Summary ==================== > > Name: MorphicExtras-hjh.106 > Author: hjh > Time: 21 January 2013, 6:18:34.106 am > UUID: 16ee4f0e-5230-1948-939e-4648fa9f5501 > Ancestors: MorphicExtras-bf.104 > > CalendarChooserMorph by Jon Hylands > <[hidden email]> > > http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20111103/fb5cbdc0/MorphicExtras-CalendarChooser.obj > > Updated #date accessor method to initialize. > > =============== Diff against MorphicExtras-bf.104 =============== > > Item was changed: > SystemOrganization addCategory: #'MorphicExtras-Demo'! > SystemOrganization addCategory: #'MorphicExtras-AdditionalSupport'! > SystemOrganization addCategory: #'MorphicExtras-AdditionalMorphs'! > SystemOrganization addCategory: #'MorphicExtras-Widgets'! > SystemOrganization addCategory: #'MorphicExtras-Books'! > SystemOrganization addCategory: #'MorphicExtras-Postscript Filters'! > SystemOrganization addCategory: #'MorphicExtras-Support'! > SystemOrganization addCategory: #'MorphicExtras-SoundInterface'! > SystemOrganization addCategory: #'MorphicExtras-Undo'! > SystemOrganization addCategory: #'MorphicExtras-Postscript Canvases'! > SystemOrganization addCategory: #'MorphicExtras-PartsBin'! > SystemOrganization addCategory: #'MorphicExtras-AdditionalWidgets'! > SystemOrganization addCategory: #'MorphicExtras-Flaps'! > SystemOrganization addCategory: #'MorphicExtras-Navigators'! > SystemOrganization addCategory: #'MorphicExtras-GeeMail'! > SystemOrganization addCategory: #'MorphicExtras-Palettes'! > SystemOrganization addCategory: #'MorphicExtras-Leds'! > SystemOrganization addCategory: #'MorphicExtras-SqueakPage'! > SystemOrganization addCategory: #'MorphicExtras-Text Support'! > SystemOrganization addCategory: #'MorphicExtras-Obsolete'! > SystemOrganization addCategory: #'MorphicExtras-EToy-Download'! > + SystemOrganization addCategory: #'MorphicExtras-CalendarChooser'! > > Item was added: > + Object subclass: #CalendarChooserDay > + instanceVariableNames: 'date bounds owner highlighted' > + classVariableNames: '' > + poolDictionaries: '' > + category: 'MorphicExtras-CalendarChooser'! > + > + !CalendarChooserDay commentStamp: 'Jon 11/2/2011 21:22' prior: 0! > + A CalendarChooserDay represents a specific day on a monthly calendar. > + > + Instance Variables > + bounds: <Rectangle> > + date: <Date> > + highlighted: <Boolean> > + owner: <CalendarChooserMorph> > + > + bounds > + - owner-relative bounding box > + > + date > + - the specific date (year/month/day) the CalendarChooserDay represents > + > + highlighted > + - flag to keep track of when a CalendarChooserDay has the mouse dragging over it, and is thus highlighted > + > + owner > + - the morph that contains the CalendarChooserDay, and all its siblings > + ! > > Item was added: > + ----- Method: CalendarChooserDay class>>on:for: (in category 'instance creation') ----- > + on: aDate for: aCalendarChooserMorph > + > + ^self new > + date: aDate; > + owner: aCalendarChooserMorph; > + yourself. > + ! > > Item was added: > + ----- Method: CalendarChooserDay>>bounds (in category 'accessing') ----- > + bounds > + > + ^ bounds! > > Item was added: > + ----- Method: CalendarChooserDay>>bounds: (in category 'accessing') ----- > + bounds: aRectangle > + > + bounds := aRectangle! > > Item was added: > + ----- Method: CalendarChooserDay>>date (in category 'accessing') ----- > + date > + > + ^ date! > > Item was added: > + ----- Method: CalendarChooserDay>>date: (in category 'accessing') ----- > + date: aDate > + > + date := aDate. > + ! > > Item was added: > + ----- Method: CalendarChooserDay>>debugPrint (in category 'printing') ----- > + debugPrint > + > + ^(WriteStream on: (String new: 10)) > + print: self class; > + nextPutAll: ' ('; > + print: self date; > + nextPutAll: ' - '; > + print: self bounds; > + nextPut: $); > + contents! > > Item was added: > + ----- Method: CalendarChooserDay>>drawOn:offset: (in category 'drawing') ----- > + drawOn: aCanvas offset: origin > + > + | box dayString textColor textTopLeft textWidth today | > + dayString := date dayOfMonth printString. > + textWidth := owner weekdayFont widthOfString: dayString. > + textTopLeft := bounds topCenter translateBy: (textWidth // -2) @ 3. > + box := ((textTopLeft extent: textWidth @ owner weekdayFont height) insetBy: -8 @ -1) translateBy: origin. > + today := date = Date today. > + textColor := date month = owner date month > + ifTrue: [Color black] > + ifFalse: [Color veryLightGray]. > + (date = owner date or: [self highlighted]) > + ifTrue: [ > + | lineColor fillColor | > + lineColor := today > + ifTrue: [Color red] > + ifFalse: [Color veryLightGray]. > + fillColor := self highlighted > + ifTrue: [Color veryVeryLightGray] > + ifFalse: [Color veryLightGray]. > + aCanvas fillOval: box color: fillColor borderWidth: 1 borderColor: lineColor]. > + today & (date ~= owner date) & self highlighted not > + ifTrue: [aCanvas fillOval: box color: Color white borderWidth: 1 borderColor: Color red]. > + aCanvas > + drawString: dayString > + at: textTopLeft + origin > + font: owner weekdayFont > + color: textColor.! > > Item was added: > + ----- Method: CalendarChooserDay>>highlighted (in category 'accessing') ----- > + highlighted > + > + ^highlighted! > > Item was added: > + ----- Method: CalendarChooserDay>>highlighted: (in category 'accessing') ----- > + highlighted: aBoolean > + > + highlighted := aBoolean! > > Item was added: > + ----- Method: CalendarChooserDay>>initialize (in category 'initializing') ----- > + initialize > + > + self highlighted: false! > > Item was added: > + ----- Method: CalendarChooserDay>>owner (in category 'accessing') ----- > + owner > + > + ^ owner! > > Item was added: > + ----- Method: CalendarChooserDay>>owner: (in category 'accessing') ----- > + owner: aCalendarChooserMorph > + > + owner := aCalendarChooserMorph! > > Item was added: > + ----- Method: CalendarChooserDay>>printOn: (in category 'printing') ----- > + printOn: aStream > + > + aStream > + print: self class; > + nextPutAll: ' ('; > + print: self date; > + nextPut: $)! > > Item was added: > + BorderedMorph subclass: #CalendarChooserMorph > + instanceVariableNames: 'date days touchPoints' > + classVariableNames: '' > + poolDictionaries: '' > + category: 'MorphicExtras-CalendarChooser'! > + > + !CalendarChooserMorph commentStamp: 'Jon 11/2/2011 21:24' prior: 0! > + A CalendarChooserMorph is a standalone morph that represents a selectable monthly calendar. > + > + Instance Variables > + date: <Date> > + days: <OrderedCollection of: <CalendarChooserDay>> > + touchPoints: <Dictionary key: <Rectangle> value: <Symbol>> > + > + date > + - the currently selected date (always within the current month) > + > + days > + - all the days that are visible, including days from the previous month, the current month, and the next month > + > + touchPoints > + - extra hotspots that are touch-responsive (key rectangle is in world coordinates) > + ! > > Item was added: > + ----- Method: CalendarChooserMorph class>>on: (in category 'instance creation') ----- > + on: aDate > + > + ^self new > + "extent: 200 @ 160;" > + date: aDate; > + yourself. > + ! > > Item was added: > + ----- Method: CalendarChooserMorph class>>openOn: (in category 'instance creation') ----- > + openOn: aDate > + > + ^(self on: aDate) openInWorld! > > Item was added: > + ----- Method: CalendarChooserMorph>>computeDays (in category 'private') ----- > + computeDays > + "Populate the days instance variable with CalendarChooserDay instances for the receiver's month." > + > + | cellHeight cellWidth height topLeft lastMonth nextMonth theDay thisMonth | > + topLeft := 0 @ 25. > + height := self bounds height - 25. > + cellHeight := height // 8. > + height := height - cellHeight. > + cellWidth := self bounds width // 7. > + lastMonth := date month previous. > + thisMonth := date month. > + nextMonth := date month next. > + days := OrderedCollection new. > + 1 to: 6 do: [:lineIndex | > + | yOffset | > + yOffset := topLeft y + (lineIndex * cellHeight). > + (self daysForLine: lineIndex) withIndexDo: [:day :dayIndex | > + | cellPosX dayDate | > + dayDate := thisMonth asDate addDays: day - 1. > + (lineIndex = 1 and: [day > 7]) > + ifTrue: [dayDate := lastMonth asDate addDays: day - 1]. > + (lineIndex > 4 and: [day < 15]) > + ifTrue: [dayDate := nextMonth asDate addDays: day - 1]. > + cellPosX := cellWidth * (dayIndex - 1). > + days add: (theDay := CalendarChooserDay on: dayDate for: self). > + theDay bounds: (cellPosX @ yOffset extent: cellWidth @ cellHeight)]]! > > Item was added: > + ----- Method: CalendarChooserMorph>>date (in category 'accessing') ----- > + date > + > + date isNil ifTrue: [ self date: Date today]. > + ^date! > > Item was added: > + ----- Method: CalendarChooserMorph>>date: (in category 'accessing') ----- > + date: aDate > + > + | recompute | > + recompute := date isNil or: [date month ~= aDate month]. > + date := aDate. > + recompute > + ifTrue: [self computeDays]! > > Item was added: > + ----- Method: CalendarChooserMorph>>daysForLine: (in category 'private') ----- > + daysForLine: aNumber > + "Return an array of numbers that correspond to the day-of-month numbers of the given line (row) > + in the calendar for the month of the receiver's date." > + > + | dayCount firstWeekday previousDayCount previousMonthDays lastDay | > + dayCount := date month daysInMonth. > + firstWeekday := Date firstWeekdayOfMonth: date monthIndex year: date year. > + previousDayCount := date month previous daysInMonth. > + "First case - handle the first line specially" > + aNumber = 1 > + ifTrue: [ > + "If this month's first day is Sunday, the first line is the last week from last month" > + firstWeekday = 1 > + ifTrue: [^(previousDayCount - 6 to: previousDayCount) asArray]. > + > + "Otherwise, its a mix of last month and this month" > + previousMonthDays := (firstWeekday - 1 to: 1 by: -1) collect: [:each | previousDayCount - each + 1]. > + ^previousMonthDays, ((1 to: 7) asArray copyFrom: 1 to: 7 - previousMonthDays size)]. > + > + "Recompute the last day from the previous line (I love recursion)" > + lastDay := (self daysForLine: aNumber - 1) last. > + "Second case - the first week of this month starts on Sunday" > + (aNumber = 2 and: [lastDay = previousDayCount]) > + ifTrue: [^(1 to: 7) asArray]. > + > + "Third case - the first week of next month starts on Sunday" > + lastDay = dayCount > + ifTrue: [^(1 to: 7) asArray]. > + > + "Fourth case - everything else" > + ^(lastDay + 1 to: lastDay + 7) collect: [:each | > + each <= dayCount > + ifTrue: [each] > + ifFalse: [each - dayCount]]! > > Item was added: > + ----- Method: CalendarChooserMorph>>defaultBounds (in category 'initializing') ----- > + defaultBounds > + "Answer the default bounds for the receiver." > + > + ^0 @ 0 corner: 200 @ 160! > > Item was added: > + ----- Method: CalendarChooserMorph>>drawDaysOn: (in category 'drawing') ----- > + drawDaysOn: aCanvas > + > + days do: [:each | > + each > + drawOn: aCanvas > + offset: self bounds topLeft]! > > Item was added: > + ----- Method: CalendarChooserMorph>>drawMonthHeaderOn: (in category 'drawing') ----- > + drawMonthHeaderOn: aCanvas > + > + | headerWidth headerString box textBox textTopLeft monthBox monthNameWidth yearBox previousMonthBox nextMonthBox | > + headerString := self date asMonth printString. > + headerWidth := self monthNameFont widthOfString: headerString. > + box := self bounds topLeft extent: self bounds width @ 23. > + textTopLeft := self bounds topCenter translateBy: (headerWidth // -2) @ 5. > + textBox := textTopLeft extent: headerWidth @ self monthNameFont height. > + monthNameWidth := self monthNameFont widthOfString: self date monthName, ' '. > + monthBox := textBox topLeft extent: monthNameWidth @ textBox height. > + yearBox := monthBox topRight corner: textBox bottomRight. > + previousMonthBox := (self bounds topLeft translateBy: 10 @ 5) extent: 10 @ self monthNameFont height. > + nextMonthBox := (self bounds topRight translateBy: -20 @ 5) extent: 10 @ self monthNameFont height. > + touchPoints > + at: monthBox put: #handleMonthNameTouched; > + at: yearBox put: #handleYearTouched; > + at: (previousMonthBox expandBy: 10 @ 5) put: #handlePreviousMonthTouched; > + at: (nextMonthBox expandBy: 10 @ 5) put: #handleNextMonthTouched. > + aCanvas > + frameAndFillRectangle: box > + fillColor: Color veryLightGray > + borderWidth: 1 > + borderColor: Color black; > + > + line: box bottomLeft > + to: box bottomRight > + width: 2 > + color: Color black; > + > + drawString: '<' > + at: previousMonthBox origin > + font: self monthNameFont > + color: Color black; > + > + drawString: '>' > + at: nextMonthBox origin > + font: self monthNameFont > + color: Color black; > + > + drawString: headerString > + at: (self bounds topCenter translateBy: (headerWidth // -2) @ 5) > + font: self monthNameFont > + color: Color black. > + ! > > Item was added: > + ----- Method: CalendarChooserMorph>>drawOn: (in category 'drawing') ----- > + drawOn: aCanvas > + > + touchPoints := Dictionary new. > + aCanvas > + clipBy: self bounds > + during: [:clippedCanvas | > + clippedCanvas > + fillRectangle: self bounds > + color: Color white. > + > + self > + drawMonthHeaderOn: clippedCanvas; > + drawWeekDayNamesOn: clippedCanvas; > + drawDaysOn: clippedCanvas; > + drawTodayOn: aCanvas. > + > + clippedCanvas > + frameRectangle: self bounds > + width: 1 > + color: Color black]. > + > + > + > + ! > > Item was added: > + ----- Method: CalendarChooserMorph>>drawTodayOn: (in category 'drawing') ----- > + drawTodayOn: aCanvas > + > + | text textHeight textTopLeft textWidth textBox | > + text := 'Today: ', (Date today printFormat: #(2 1 3 $ 3 1 1)). > + textWidth := self weekdayFont widthOfString: text. > + textHeight := self weekdayFont height. > + textTopLeft := self bounds bottomCenter translateBy: (textWidth // -2) @ (textHeight negated - 5). > + textBox := textTopLeft extent: textWidth @ textHeight. > + touchPoints at: textBox put: #handleTodayTouched. > + aCanvas > + drawString: text > + at: textTopLeft > + font: self weekdayFont > + color: Color gray! > > Item was added: > + ----- Method: CalendarChooserMorph>>drawWeekDayNamesOn: (in category 'drawing') ----- > + drawWeekDayNamesOn: aCanvas > + > + | cellHeight height topLeft topRight cellWidth | > + topLeft := self bounds topLeft translateBy: 0 @ 25. > + topRight := self bounds topRight translateBy: 0 @ 25. > + height := self bounds height - 25. > + cellHeight := height // 8. > + cellWidth := self bounds width // 7. > + aCanvas > + line: (topLeft translateBy: 0 @ cellHeight) > + to: (topRight translateBy: 0 @ cellHeight) > + width: 1 > + color: Color black. > + > + #('Sun' 'Mon' 'Tue' 'Wed' 'Thu' 'Fri' 'Sat') withIndexDo: [:dayName :dayIndex | > + | cellPosX cellTopCenter textWidth | > + cellPosX := cellWidth * (dayIndex - 1). > + cellTopCenter := topLeft translateBy: ((cellPosX + (cellWidth // 2)) + 1) @ 0. > + textWidth := self weekdayFont widthOfString: dayName. > + aCanvas > + drawString: dayName > + at: (cellTopCenter translateBy: (textWidth // -2) @ 3) > + font: self weekdayFont > + color: Color darkGray] > + ! > > Item was added: > + ----- Method: CalendarChooserMorph>>extent: (in category 'accessing') ----- > + extent: aPoint > + "Since the day objects cache their bounding box, we have to recompute them if the receiver resizes." > + > + | result | > + result := super extent: aPoint. > + date notNil > + ifTrue: [self computeDays]. > + ^result! > > Item was added: > + ----- Method: CalendarChooserMorph>>handleMonthNameTouched (in category 'event handling') ----- > + handleMonthNameTouched > + > + | newMonthName dayCount | > + newMonthName := ListChooser > + chooseItemFrom: #('January' 'February' 'March' 'April' 'May' 'June' 'July' > + 'August' 'September' 'October' 'November' 'December') > + title: 'Choose a month:'. > + > + newMonthName isNil > + ifTrue: [^self]. > + > + dayCount := (Month month: newMonthName year: date year) daysInMonth. > + self date: (Date newDay: (date dayOfMonth min: dayCount) month: newMonthName year: date year). > + self changed. > + ! > > Item was added: > + ----- Method: CalendarChooserMorph>>handleNextMonthTouched (in category 'event handling') ----- > + handleNextMonthTouched > + > + self date: (date addMonths: 1). > + self changed. > + ! > > Item was added: > + ----- Method: CalendarChooserMorph>>handlePreviousMonthTouched (in category 'event handling') ----- > + handlePreviousMonthTouched > + > + self date: (date addMonths: -1). > + self changed. > + ! > > Item was added: > + ----- Method: CalendarChooserMorph>>handleTodayTouched (in category 'event handling') ----- > + handleTodayTouched > + > + self date: Date today. > + self changed. > + ! > > Item was added: > + ----- Method: CalendarChooserMorph>>handleYearTouched (in category 'event handling') ----- > + handleYearTouched > + > + | newYear dayCount | > + newYear := ListChooser > + chooseItemFrom: ((2000 to: 2020) collect: [:each | each printString]) > + title: 'Choose a year:' > + addAllowed: true. > + > + newYear isNil > + ifTrue: [^self]. > + > + newYear := newYear asNumber. > + dayCount := (Month month: date monthIndex year: newYear) daysInMonth. > + self date: (Date newDay: (date dayOfMonth min: dayCount) month: date monthIndex year: newYear). > + self changed.! > > Item was added: > + ----- Method: CalendarChooserMorph>>handlesMouseDown: (in category 'event handling') ----- > + handlesMouseDown: event > + > + ^true! > > Item was added: > + ----- Method: CalendarChooserMorph>>initialize (in category 'initializing') ----- > + initialize > + > + super initialize. > + touchPoints := Dictionary new. > + ! > > Item was added: > + ----- Method: CalendarChooserMorph>>monthNameFont (in category 'accessing') ----- > + monthNameFont > + > + ^TTCFont familyName: 'BitstreamVeraSans' pointSize: 11 emphasis: 3! > > Item was added: > + ----- Method: CalendarChooserMorph>>mouseDown: (in category 'event handling') ----- > + mouseDown: event > + "Handle mouse down and mouse movement. Highlight the day under the mouse." > + > + | morphRelativeHitPoint | > + morphRelativeHitPoint := event cursorPoint translateBy: bounds origin negated. > + days do: [:each | > + each highlighted: (each bounds containsPoint: morphRelativeHitPoint)]. > + self changed. > + ! > > Item was added: > + ----- Method: CalendarChooserMorph>>mouseMove: (in category 'event handling') ----- > + mouseMove: event > + > + self mouseDown: event! > > Item was added: > + ----- Method: CalendarChooserMorph>>mouseUp: (in category 'event handling') ----- > + mouseUp: event > + "Check for hotspot hits - handle them if they match. > + Otherwise, convert the event cursor to morph-local, and find the day under it. > + If there is nothing under the mouse when it goes up, nothing happens." > + > + | morphRelativeHitPoint | > + touchPoints keysAndValuesDo: [:eachBox :eachSelector | > + (eachBox containsPoint: event cursorPoint) > + ifTrue: [self perform: eachSelector]]. > + morphRelativeHitPoint := event cursorPoint translateBy: bounds origin negated. > + days do: [:each | > + each highlighted: false. > + (each bounds containsPoint: morphRelativeHitPoint) > + ifTrue: [self date: each date]]. > + self changed. > + ! > > Item was added: > + ----- Method: CalendarChooserMorph>>weekdayFont (in category 'accessing') ----- > + weekdayFont > + > + ^TTCFont familyName: 'BitstreamVeraSans' pointSize: 10 emphasis: 0! > > |
Free forum by Nabble | Edit this page |