Scratch

'From MIT Squeak 0.9.4 (June 1, 2003) [No updates present.] on 20 September 2010 at 3:32:28 pm'!
EventHatMorph subclass: #ProcedureHatBlockMorph
    instanceVariableNames: 'argMorphs commandSpec addInputVarMorph removeInputVarMorph '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Scratch-Blocks'!

!ProcedureHatBlockMorph methodsFor: 'as yet unclassified'!
addInputVar
    self commandSpec: commandSpec , '%s'.
    self addMorphBack: removeInputVarMorph.
    self addMorphBack: addInputVarMorph.
    self replaceArgMorph: (self argumentAt: argMorphs size)
        by: (VariableBlockMorph new commandSpec: ('input' , argMorphs size asString) localized;
             isSpecialForm: true).
    self fixBlockLayout! !

!ProcedureHatBlockMorph methodsFor: 'as yet unclassified'!
addLabel
    | t1 t2 t3 t4 t5 |
    commandSpec ifNil: [^ self].
    t5 _ self nextBlock.
    self removeAllMorphsIn: (self submorphs reject: [:t6 | t6 = t5]).
    t1 _ CommandBlockMorph parseCommandSpec: commandSpec.
    t2 _ t1 select: [:t7 | CommandBlockMorph isArgSpec: t7].
    [argMorphs size > t2 size]
        whileTrue: 
            [t4 _ argMorphs last.
            argMorphs remove: t4.
            (t4 isKindOf: BlockMorph)
                ifTrue: [t4 openInWorld]].
    [argMorphs size < t2 size]
        whileTrue: [argMorphs addLast: (self argMorphFor: (t2 at: argMorphs size + 1))].
    t3 _ 1.
    t1 do: 
        [:t7 | 
        (CommandBlockMorph isArgSpec: t7)
            ifTrue: 
                [t4 _ argMorphs at: t3.
                t3 _ t3 + 1]
            ifFalse: [t4 _ self labelMorphFor: t7].
        self addMorphBack: t4].
    self isReporter
        ifTrue: 
            [t4 _ submorphs first.
            (t4 isKindOf: ChoiceArgMorph)
                | (t4 isKindOf: SpriteArgMorph) ifTrue: [self addMorphFront: (Morph new color: Color transparent;
                     extent: 2 @ 5)].
            t4 _ submorphs last.
            (t4 isKindOf: ChoiceArgMorph)
                | (t4 isKindOf: SpriteArgMorph) ifTrue: [self addMorphBack: (Morph new color: Color transparent;
                     extent: 2 @ 5)]]! !

!ProcedureHatBlockMorph methodsFor: 'as yet unclassified'!
argMorphFor: t1 
    ^ ExpressionArgMorph new stringExpression: ''! !

!ProcedureHatBlockMorph methodsFor: 'as yet unclassified'!
argumentAt: t1 
    ^ argMorphs at: t1! !

!ProcedureHatBlockMorph methodsFor: 'as yet unclassified'!
commandSpec: t1 
    commandSpec _ t1.
    self addLabel! !

!ProcedureHatBlockMorph methodsFor: 'as yet unclassified'!
fixBlockLayout
    | t1 |
    super fixBlockLayout.
    t1 _ self position + (10 @ 18).
    self addMorphBack: addInputVarMorph.
    argMorphs size > 1 ifTrue: [self addMorphBack: removeInputVarMorph].
    submorphs do: [:t2 | (t2 isKindOf: ExpressionArgMorph)
            | (t2 isKindOf: StringMorph) | (t2 isKindOf: VariableBlockMorph)
            ifTrue: 
                [t2 position: t1.
                t1 _ t2 topRight + (3 @ 0)]].
    removeInputVarMorph position: t1.
    t1 _ removeInputVarMorph topRight + (14 @ 0).
    addInputVarMorph position: t1 + (-20 @ -1).
    t1 _ addInputVarMorph topRight + (3 @ 0).
    self width: t1 x - self position x! !

!ProcedureHatBlockMorph methodsFor: 'as yet unclassified'!
initialize
    super initialize.
    argMorphs _ OrderedCollection new.
    self commandSpec: 'procedure %s with inputs'.
    addInputVarMorph _ ImageMorph new form: ((ScratchFrameMorph skinAt: #arrowOpenComment)
                    rotateBy: -90).
    removeInputVarMorph _ ImageMorph new form: ((ScratchFrameMorph skinAt: #arrowOpenComment)
                    rotateBy: 90).
    self addMorphBack: addInputVarMorph.
    self fixBlockLayout! !

!ProcedureHatBlockMorph methodsFor: 'as yet unclassified'!
labelMorphFor: t1 
    | t2 |
    t2 _ t1.
    commandSpec isUnicode ifTrue: [t2 _ UTF8 withAll: t2].
    ^ (StringMorph contents: t2 font: (ScratchFrameMorph getFont: #Label))
        color: Color white! !

!ProcedureHatBlockMorph methodsFor: 'as yet unclassified'!
mouseDown: t1 
    t1 hand newKeyboardFocus: nil.
    t1 anyButtonPressed
        ifTrue: 
            [(addInputVarMorph containsPoint: t1 cursorPoint)
                ifTrue: [^ self addInputVar].
            (removeInputVarMorph containsPoint: t1 cursorPoint)
                ifTrue: [^ self removeInputVar]].
    ^ super mouseDown: t1! !

!ProcedureHatBlockMorph methodsFor: 'as yet unclassified'!
removeInputVar
    self commandSpec: (commandSpec allButLast: 2).
    argMorphs size = 1 ifTrue: [removeInputVarMorph delete].
    self addMorphBack: addInputVarMorph.
    self fixBlockLayout! !

!ProcedureHatBlockMorph methodsFor: 'as yet unclassified'!
replaceArgMorph: t1 by: t2 
    argMorphs _ argMorphs
                collect: [:t3 | t3 == t1
                        ifTrue: [t2]
                        ifFalse: [t3]].
    self replaceSubmorph: t1 by: t2.
    self layoutChanged! !

!ScriptableScratchMorph methodsFor: 'blocks'!
hatBlockType: t1 
    | t2 t3 |
    'E' = t1
        ifTrue: 
            [t3 _ ''.
            (t2 _ self ownerThatIsA: ScratchStageMorph) ifNotNil: [t3 _ t2 defaultEventName].
            ^ EventHatMorph new scriptOwner: self;
             eventName: t3].
    'K' = t1 ifTrue: [^ KeyEventHatMorph new scriptOwner: self].
    'M' = t1 ifTrue: [^ MouseClickEventHatMorph new scriptOwner: self].
    'S' = t1 ifTrue: [^ EventHatMorph new forStartEvent scriptOwner: self].
    'W' = t1 ifTrue: [^ WhenHatBlockMorph new scriptOwner: self].
    'P' = t1 ifTrue: [^ ProcedureHatBlockMorph new scriptOwner: self]! !

!ScriptableScratchMorph methodsFor: 'blocks'!
blockFromSpec: t1 color: t2 
    | t3 t4 t5 t6 t7 t8 t9 |
    t3 _ ScratchTranslator translationFor: (t1 at: 1).
    t9 _ CommandBlockMorph argPermutationForSpec: (t1 at: 1)
                withTranslation: t3.
    t4 _ t1 at: 2.
    t5 _ (t1 at: 3) asSymbol.
    t6 _ self defaultArgsFor: t1.
    (#(#E #K #M #S #W #P ) includes: t4)
        ifTrue: [^ (self hatBlockType: t4)
                color: t2].
    (t4 includes: $c)
        ifTrue: [t5 = #doIfElse | (t3 = 'switch')
                ifTrue: [t7 _ IfElseBlockMorph new isSpecialForm: true]
                ifFalse: [t7 _ CBlockMorph new isSpecialForm: true]]
        ifFalse: [(t4 includes: $r)
                | (t4 includes: $b)
                ifTrue: [t7 _ ReporterBlockMorph new]
                ifFalse: [t7 _ CommandBlockMorph new]].
    (t4 includes: $b)
        ifTrue: [t7 isBoolean: true].
    (t4 includes: $s)
        ifTrue: [t7 isSpecialForm: true].
    (t4 includes: $t)
        ifTrue: [t7 isTimed: true].
    (ScriptableScratchMorph isSpriteSpecificTarget: self selector: t5)
        ifTrue: [t8 _ self]
        ifFalse: [t8 _ self ownerThatIsA: ScratchStageMorph].
    ^ t7 argPermutation: t9;
     color: t2;
     selector: t5;
     commandSpec: t3;
     defaultArgs: t6;
     receiver: t8! !

('' #P #-)