[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
|