[squeak-dev] The Inbox: MorphicExtras-hjh.106.mcz

Chris Muller asqueaker at gmail.com
Tue Jan 22 00:41:36 UTC 2013


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,  <commits at source.squeak.org> 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
> <jon at huv.com>
>
> 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!
>
>


More information about the Squeak-dev mailing list