[squeak-dev] The Inbox: MorphicExtras-hjh.106.mczcommits at source.squeak.org commits at source.squeak.orgMon Jan 21 06:19:32 UTC 2013
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 |