Scratch

'From MIT Squeak 0.9.4 (June 1, 2003) [No updates present.] on 12 August 2008 at 5:24:59 pm'!
BlockMorph subclass: #HatBlockMorph
    instanceVariableNames: 'scriptNameMorph indicatorMorph scriptOwner parameters isClickable isShowing showHideMorph '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Scratch-Blocks'!

!BlockMorph methodsFor: 'event handling' stamp: 'jens 8/11/2008 12:32'!
handlesMouseDown: evt

    ^self isHidden not
! !

!BlockMorph methodsFor: 'private' stamp: 'jens 8/11/2008 12:56'!
blockAttachPoints: aSet
    "Answer a collection of possible attachment points for me. Each entry is an Association mapping a point to the morph to which a dropping command block could be attached."

    | nextB result |
    self isHidden ifTrue: [^self].
    result _ #().
    (self isKindOf: HatBlockMorph) ifFalse: [
        ScratchTranslator isRTL
            ifTrue: [result _ result copyWith: (self topRight -> self)]
            ifFalse: [result _ result copyWith: (self topLeft -> self)]].
    nextB _ self nextBlock.
    nextB ifNil:[
        self isStopOrForever ifFalse: [
            ScratchTranslator isRTL
                ifTrue: [result _ result copyWith: (self bottomRight -> self)]
                ifFalse: [result _ result copyWith: (self bottomLeft -> self)]]].

    nextB
        ifNotNil: [nextB blockAttachPoints: aSet].

    aSet addAll: result.
! !


!HatBlockMorph methodsFor: 'initialization' stamp: 'jens 8/12/2008 12:45'!
initialize

    super initialize.
    self color: (Color h: 41 s: 0.85 v: 0.9).
    self extent: 92@38.
    scriptOwner _ nil.
    isShowing _ true.

    scriptNameMorph _ StringMorph new
        contents: 'script';
        font: (ScratchFrameMorph getFont: #Label);
        forceUnicodeRendering: true;
        color: Color white.
    self addMorph: scriptNameMorph.
! !

!HatBlockMorph methodsFor: 'drawing' stamp: 'jens 8/12/2008 12:57'!
drawBottomEdgeOn: aCanvas
    isShowing 
        ifTrue: [ super drawBottomEdgeOn: aCanvas]
        ifFalse: [ self drawSmoothBottomEdgeOn: aCanvas]

! !

!HatBlockMorph methodsFor: 'drawing' stamp: 'jens 8/8/2008 23:48'!
drawSmoothBottomEdgeOn: aCanvas

    | right y |
    right _ self width - 1.
    y _ self height - 7.

    self drawHLineFrom: 1 to: right - 1 y: y color: color on: aCanvas.
    self drawHLineFrom: 2 to: right - 2 y: y + 1 color: color on: aCanvas.
    self drawHLineFrom: 3 to: right - 2 y: y + 2 color: shadowColor on: aCanvas.

    self drawPoint: (right - 1)@y color: shadowColor on: aCanvas.
    self drawPoint: (right - 2)@(y + 1) color: shadowColor on: aCanvas.
! !

!HatBlockMorph methodsFor: 'event handling' stamp: 'jens 8/12/2008 12:59'!
mouseDown: evt
    "Handle a mouse click. Left button either drags or performs click action. Right button brings up a menu."

    | p |
    p _ evt cursorPoint.

    showHideMorph ifNotNil: [ ((showHideMorph bounds expandBy: 4) containsPoint: p) ifTrue: [^ self toggleShowing]].
    super mouseDown: evt! !

!HatBlockMorph methodsFor: 'collapsing/expanding' stamp: 'jens 8/12/2008 12:47'!
addShowHideMorph
    showHideMorph _ ImageMorph new form: (ScratchFrameMorph skinAt: #arrowOpenComment).
    self addMorphFront: showHideMorph.
! !

!HatBlockMorph methodsFor: 'collapsing/expanding' stamp: 'jens 8/12/2008 13:30'!
attachBlock: aBlock
    super attachBlock: aBlock.
    showHideMorph isNil ifTrue: [
            self addShowHideMorph ]! !

!HatBlockMorph methodsFor: 'collapsing/expanding' stamp: 'jens 8/12/2008 13:42'!
changed
    self nextBlock ifNil: [showHideMorph ifNotNil: [
            self removeShowHideMorph;
                 fixBlockLayout ]].
    super changed! !

!HatBlockMorph methodsFor: 'collapsing/expanding' stamp: 'jens 8/12/2008 17:24'!
position: aPoint
    "temporary workaround to display the toggle when reading a new project from disk"
    super position: aPoint.
    self nextBlock ifNotNil: [
        showHideMorph isNil ifTrue: [
            self addShowHideMorph ]]! !

!HatBlockMorph methodsFor: 'collapsing/expanding' stamp: 'jens 8/12/2008 12:48'!
removeShowHideMorph
    showHideMorph delete.
    showHideMorph _ nil! !

!HatBlockMorph methodsFor: 'collapsing/expanding' stamp: 'jens 8/12/2008 12:55'!
toggleShowing

    isShowing _ isShowing not.
    isShowing
        ifTrue: [
            self nextBlock isHidden: false.
            showHideMorph form: (ScratchFrameMorph skinAt: #arrowOpenComment)]
        ifFalse: [
            self nextBlock isHidden: true.
            showHideMorph form: (ScratchFrameMorph skinAt: #arrowClosedComment)].

    "kludge to force a complete repaint:"
    World activeHand grabMorph: self
! !


!BlockMorph reorganize!
('initialization' initialize)
('accessing' acceptsDroppedReporters acceptsTypeOf: canBecomeWatcher closestAttachTargetIn: codeString color: helpScreenName isBooleanReporter isForever isReporter isSpecialForm isSpecialForm: isStop isStopOrForever litUp: newScriptOwner: presentHelpScreen receiver receiver: scratchProc showErrorFeedback)
('block enumerating' blockSequence bottomBlock firstBlockList nextBlock nextBlock: topBlock tupleSequence)
('drawing' computeHighlightColors drawBodyOn: drawBottomEdgeOn: drawFinalOn:fromCanvas: drawHLineFrom:to:y:color:on: drawOn: drawPoint:color:on: drawReporterBodyOn: drawSmoothBottomEdgeOn: drawSmoothTopEdgeOn: drawStopBodyOn: drawTopEdgeOn:)
('drawing-optimization' changed fullBounds fullDrawOn: invalidRect: updateCachedFeedbackForm updateCachedForm)
('dropping/grabbing' aboutToBeGrabbedBy: handleReporterDrop justDroppedInto:event: rejectDropEvent: rootForGrabOf: slideBackToFormerSituation:)
('event handling' click: delete doubleClick: duplicate handleTool:hand: handlesMouseDown: mouseDown: rightButtonMenu showTuples startDrag: wantsKeyboardFocusFor:)
('stepping' step stepTime)
('processes' isRunning start stop toggleProcess)
('object i/o' fieldsVersion initFieldsFrom:version: storeFieldsOn:)
('private' attachBlock: blockAttachPoints: clearProcess copyRecordingIn: fixBlockLayout layoutChanged nonControlFlowSubmorphs printCodeOn:indent: printCodeSubmorph:on:)
!