Scratch

; This file defines non-primitive sprite commands except Control commands, which are defined in thread.logo.

; ******* Control *******

; Note: doForever, doIf, doIfElse, doRepeat, doWaitUntil, and doReturn are defined in thread.logo

define wait:elapsed:from: [secs] [timedCommand :secs [] []]
define mwait:elapsed:from: [secs] [timedCommand (:secs / 1000) [] []]

to timedCommand :secs :startAction :endAction
    if thread-end-msecs = [] [
        set-thread-end-msecs %timer + (1000 * :secs)
        run :startAction
        yield stop]
    if %timer < thread-end-msecs [yield stop]
    run :endAction
    set-thread-end-msecs []
    set-thread-tmp []
end

to broadcast: :msg
    ignore startThreadsForBroadcast :msg
end

to doBroadcastAndWait :msg
    if empty? thread-tmp [
        let [thrds startThreadsForBroadcast :msg]
        if empty? :thrds [stop]
        set-thread-tmp :thrds
        yield stop]
    dolist [thrd thread-tmp] [if first :thrd [yield stop]]    ; found a running thread
    set-thread-tmp []        ; all threads have stopped; we're done
end

; start threads for the given broadcast and return the list of started threads
to startThreadsForBroadcast :msg
    let [me who result []]
    if (not string? :msg) [make "msg string :msg]
    dolist [o fput stage sprites] [
        talkto :o
        dolist [scr scripts] [
            let [hat first :scr]
            if (first :hat) = "EventHatMorph [
                if (strequ (last :hat) :msg) [
                    make "result (lput (start-script :o :scr false) :result)
    ]]]]
    talkto :me
    output :result
end

to stopAll
    let [me who]
    stopAllSounds
    stop-all-threads
    dolist [s sprites][if sprite? :s [talkto :s filterReset talkbubble "||]]
    talkto stage filterReset
    talkto :me
    redrawall
end

define comment: [commentString isOpen] []  ; comments are no-ops

; ******* Motion *******

; Note: xpos, ypos, heading, and %scale are Logo reporters
; %left, %top, %w, and %h give the top, left, width, and height of the scaled & rotated sprite in screen coordinates
;   (i.e. origin at top-left corner of window, y grows down

define forward: [n] [gotoX:y: (xpos + (:n * sin heading)) (ypos + (:n * cos heading))]
define turnRight: [n] [heading: heading + :n]
define turnLeft: [n] [heading: heading - :n]

; handy shortcuts for testing
define fd [n] [forward: :n]
define rt [n] [turnRight: :n]
define lt [n] [turnLeft: :n]

to heading: :n
    if isStage? [stop]
    if :n < 0 [make "n remainder (:n + 360000000) 360]
    changed
    setheading :n
    changed
end

to pointTowards: :thing
    let [p mouseOrSpritePosition :thing]
    heading: arctan2 ((first :p) - xpos) ((last :p) - ypos)]
end

define screenLeft [] [output 1]
define screenRight [] [output screenLeft + 480]
define screenTop [] [output 26]
define screenBottom [] [output screenTop + 360]

to bounceOffEdge
    if (not touching: "edge) [stop]
    turnAwayFromEdge
    if (%left < screenLeft) [%setleft screenLeft]
    if (%top < screenTop) [%settop screenTop]
    if (%right > screenRight) [%setleft screenRight - %w]
    if (%bottom > screenBottom) [%settop screenBottom - %h]
end

to turnAwayFromEdge
    let [
        closest 10000
        d 10000
        e 0]
    make "d (max 0 (%left - screenLeft))            if :d < :closest [make "e 1 make "closest :d]
    make "d (max 0 (%top - screenTop))                if :d < :closest [make "e 2 make "closest :d]
    make "d (max 0 (screenRight - %right))        if :d < :closest [make "e 3 make "closest :d]
    make "d (max 0 (screenBottom - %bottom))    if :d < :closest [make "e 4 make "closest :d]
    if :closest > 10 [stop]
    let [dx sin heading dy cos heading]
    if :e = 1 [make "dx (max abs :dx 0.2)]
    if :e = 2 [make "dy 0 - (max abs :dy 0.2)]
    if :e = 3 [make "dx 0 - (max abs :dx 0.2)]
    if :e = 4 [make "dy (max abs :dy 0.2)]
    heading: arctan2 :dx :dy
end

to keepOnStage
    let [inset 1]
    if %right < (screenLeft + :inset) [%setleft (screenLeft + :inset - %w)]
    if %bottom < (screenTop + :inset) [%settop (screenTop + :inset - %h)]
    if %left > (screenRight - :inset) [%setleft (screenRight - :inset)]
    if %top > (screenBottom - :inset) [%settop (screenBottom - :inset)]
    updateBubble
end

to gotoX:y: :x :y
    if isStage? [stop]
    changed
    setx :x
    sety :y
    keepOnStage
    changed
end

to gotoSpriteOrMouse: :thing
    let [p mouseOrSpritePosition :thing]
    gotoX:y: (first :p) (last :p)
end

to glideSecs:toX:y:elapsed:from: :secs :dstX :dstY
    if thread-end-msecs = [] [
        set-thread-end-msecs %timer + (1000 * :secs)
        set-thread-tmp (se xpos ypos :dstX :dstY (1000 * :secs) %timer)        ; record start and end position
        yield stop]
    let [
        startX (item 1 thread-tmp)
        startY (item 2 thread-tmp)
        endX (item 3 thread-tmp)
        endY (item 4 thread-tmp)
        totalDur (item 5 thread-tmp)
        frac (%timer - (item 6 thread-tmp)) / :totalDur]
    if %timer < thread-end-msecs [
        gotoX:y:
            (:startX + (:frac * (:endX - :startX)))
            (:startY + (:frac * (:endY - :startY)))
        yield stop]
    gotoX:y: :endX :endY
    set-thread-tmp []
    set-thread-end-msecs []
end

define changeXposBy: [n] [xpos: xpos + :n]
define changeYposBy: [n] [ypos: ypos + :n]
define xpos: [n] [if not isStage? [changed setx :n keepOnStage changed]]
define ypos: [n] [if not isStage? [changed sety :n keepOnStage changed]]

define isStage? [] [output who = stage]

to mouseOrSpritePosition :thing
    if "mouse = :thing [output (se mouseX mouseY)]
    let [me who result []]
    talkto :thing
    make "result (se xpos ypos)
    talkto :me
    output :result
end

; ******* Looks *******

; Note: show and hide are Logo commands

to lookLike: :costumeNameOrNum
    if string? :costumeNameOrNum [
        if (not hasCostumeNamed :costumeNameOrNum) [
            ifelse (isNumberFormat :costumeNameOrNum)
                [make "costumeNameOrNum round (0 + :costumeNameOrNum)]
                [stop]]] ; neither a costume name nor a valid number
    if number? :costumeNameOrNum [
        let [i ((round :costumeNameOrNum - 1) % count costumes)]
        if :i < 0 [make "i :i + count costumes]
        make "costumeNameOrNum first (nth :i costumes)]
    dotimes [i count costumes][
        let [c nth :i costumes]
        if (strequ (first :c) :costumeNameOrNum) [
            setcindex :i
            let [oldxpos xpos oldypos ypos]
            changed
            setcostume (item 2 :c) (item 3 :c) (item 4 :c)
            gotoX:y: :oldxpos :oldypos
            changed]]
end

to changeCostumeIndexBy: :n
    let [i ((findcostumeIndex costume) + :n) % count costumes]
    lookLike: (item 1 (nth :i costumes))
end

define nextBackground [] [nextCostume]
to nextCostume
    let [index ((findcostumeIndex costume) + 1) % count costumes]
    lookLike: (item 1 (nth :index costumes))
end

define costumeIndex [] [output (findcostumeIndex costume) + 1]
define backgroundIndex [] [output (findcostumeIndex costume) + 1]

to findcostumeIndex :img
    if (not empty? cindex) [output cindex]
    dotimes [i count costumes][
        if :img = (item 2 (nth :i costumes)) [
            setcindex :i
            output :i]]
end

to hasCostumeNamed :costumeName
    dotimes [i count costumes][
        let [c nth :i costumes]
        if (strequ (first :c) :costumeName) [output true]]
    output false
end

to isNumberFormat :s
    let [i 1]
    if ((count :s) = 0) [output false]
    if (:s = "-) [output false]
    if (:s = ".) [output false]
    if (:s = "-.) [output false]
    if ((first :s) = "-) [make "i :i + 1]
    skipDigits
    if (:i > (count :s)) [output true]
    if ((item :i :s)  = ".) [make "i :i + 1]
    skipDigits
    output :i > (count :s)
end

to skipDigits ; uses s and i from isNumberFormat
    let [ch 0]
    loop [
        if (:i > (count :s)) [stop]
        make "ch ascii (item :i :s)
        if (or (:ch < 48)(:ch > 57)) [stop]
        make "i :i + 1]
end

define showBackground: [s] [lookLike: :s]
define showScene: [s] [lookLike: :s]
define changeBackgroundIndexBy: [n] [changeCostumeIndexBy: :n]
define changeSceneIndexBy: [n] [changeCostumeIndexBy: :n]

define say: [s] [talkbubble :s]
define think: [s] [thinkbubble :s]
define sayNothing [] [say: "||]

to say:duration:elapsed:from: :s :secs
    timedCommand :secs
        [talkbubble :s]
        [talkbubble "||]
end

to think:duration:elapsed:from: :s :secs
    timedCommand :secs
        [thinkbubble :s]
        [thinkbubble "||]
end

to changeGraphicEffect:by: :effect :delta
    if "color = :effect [setcolor color + :delta]
    if "brightness = :effect [setbrightness brightness + :delta]
    if "fisheye = :effect [setfisheye fisheye + :delta]
    if "whirl = :effect [setwhirl whirl + :delta]
    if "mosaic = :effect [setmosaic mosaic + :delta]
    if "pixelate = :effect [setpixelate pixelate + :delta]
    if "ghost = :effect [setalpha alpha - (:delta / 100)]
    changed
end

to setGraphicEffect:to: :effect :val
    if "color = :effect [setcolor :val]
    if "brightness = :effect [setbrightness :val]
    if "fisheye = :effect [setfisheye :val]
    if "whirl = :effect [setwhirl :val]
    if "mosaic = :effect [setmosaic :val]
    if "pixelate = :effect [setpixelate :val]
    if "ghost = :effect [setalpha (100 - :val) / 100]
    changed
end

to filterReset
    setcolor 0
    setbrightness 0
    setfisheye 0
    setwhirl 0
    setmosaic 0
    setpixelate 0
    setalpha 1
    changed
end

to changeSizeBy: :n
    if isStage? [stop]
    changed
    setscale %scale + (:n / 100)
    changed
end

to setSizeTo: :n
    if isStage? [stop]
    changed
    setscale (:n / 100)
    changed
end

define scale [] [output 100 * %scale]
define comeToFront [] [setsprites fput who (removeitem who sprites) changed]

to goBackByLayers: :n
    let [
        oldlist removeitem who sprites
        newlist []
        cnt (itempos who sprites) + :n - 1]
    repeat (max 0 (min :cnt count :oldlist)) [
        make "newlist lput first :oldlist :newlist
        make "oldlist butfirst :oldlist]
    make "newlist lput who :newlist
    setsprites se :newlist :oldlist
    changed
end

; ******* Math *******

; Note: arithmetic and logical operations are implemented thread.logo

to randomFrom:to: :start :stop
    let [
        low (min :start :stop)
        hi  (max :start :stop)]
    ifelse (and (:low = (int :low)) (:hi = (int :hi)))
        [output (int (rand * ((:hi + 1) - :low))) + :low]
        [output (rand * (:hi - :low)) + :low]
end

define rounded [n] [output round :n]

to computeFunction:of: :op :arg
    if (strequ "abs :op) [output abs :arg]
    if (strequ "sqrt :op) [output sqrt :arg]
    if (strequ "sin :op) [output sin :arg]
    if (strequ "cos :op) [output cos :arg]
    if (strequ "tan :op) [output tan :arg]
    if (strequ "asin :op) [output arcsin :arg]
    if (strequ "acos :op) [output arccos :arg]
    if (strequ "atan :op) [output arctan :arg]
    if (strequ "ln :op) [output ln :arg]
    if (strequ "log :op) [output (ln :arg) / (ln 10.0)]
    if (strequ "|e ^| :op) [output exp :arg]
    if (strequ "|10 ^| :op) [output power 10.0 :arg]
    output 0
end

; ******* Sound *******

; Note: beep is a Logo command

to playSound: :soundName
    let [snd soundNamed :soundName]
    if list? :snd [stop]
    ignore startSound :snd
end

to doPlaySoundAndWait :soundName
    if thread-tmp = [] [
        let [snd soundNamed :soundName]
        if list? :snd [stop]
        set-thread-tmp startSound :snd
        yield stop]
    if (isSoundPlaying? thread-tmp) [yield stop]
    set-thread-tmp []
end

to soundNamed :soundName
    if string? :soundName [
        if (not hasSoundNamed :soundName) [
            ifelse (isNumberFormat :soundName)
                [make "soundName round (0 + :soundName)]
                [output []]]] ; neither a sound name nor a valid number
    if number? :soundName [
        let [i ((:soundName - 1) % count sounds)]
        if :i < 0 [make "i :i + count sounds]
        make "soundName first (nth :i sounds)]
    dolist [s sounds] [if (strequ (item 1 :s) :soundName) [output (item 2 :s)]]
    output []
end

to hasSoundNamed :soundName
    dotimes [i count sounds][
        let [s nth :i sounds]
        if (strequ (first :s) :soundName) [output true]]
    output false
end

to drum:duration:elapsed:from: :drum :secs
    timedCommand (:secs * 60) / tempo
        [    set-thread-tmp round :drum
            midinoteon  10 thread-tmp midiVolume]
        [    midinoteoff 10 thread-tmp]
end

to noteOn:duration:elapsed:from: :key :secs
    timedCommand (:secs * 60) / tempo
        [    if midichan = [] [assign-midi-channel]
            set-thread-tmp round :key
            midinoteon  midichan thread-tmp midiVolume]
        [    midinoteoff midichan thread-tmp]
end

to rest:elapsed:from: :secs
    timedCommand (:secs * 60) / tempo
        []
        []
end

to midiInstrument: :n
    if midichan = [] [assign-midi-channel]
    midisetinstrument midichan :n
end

to assign-midi-channel
    let [
        in-use makelist 16
        ch 0
        besti 0
        bestcnt 1000]
    setmidichan []
    dotimes [i 16] [setnth :i :in-use 0]
    setnth 9 :in-use 1000
    dolist [spr (fput stage sprites)] [
        make "ch (get :spr "midichan)
        if number? :ch [setitem :ch :in-use (item :ch :in-use) + 1]]
    dotimes [i 16] [
        if (nth :i :in-use) < :bestcnt [
            make "besti :i
            make "bestcnt nth :i :in-use]]
    setmidichan :besti + 1
end

define changeTempoBy: [n] [setTempoTo: tempo + :n]
define setTempoTo: [n] [make "<tempo> (max 20 (min 500 :n))]
define tempo [] [output :<tempo>]
define changeVolumeBy: [n] [setVolumeTo: volume + :n]
define setVolumeTo: [n] [setvolume (max 0 (min 100 :n))]
define midiVolume [] [output (max 0 (min 127 ((127 * volume) / 100)))]

; ******* Pen *******

; Note: setPenDown, setPenColor, setPenHue, setPenShade,setPenSize, penSize, clearPenTrails, and stampCostume are Logo commands

define putPenDown [] [setPenDown true]
define putPenUp [] [setPenDown false]
define penColor: [c] [setPenColor :c]
define changePenHueBy: [n] [setPenHue penHue + :n]
define changePenShadeBy: [n] [setPenShade penShade + :n]
define changePenSizeBy: [n] [penSize: penSize + :n]
define setPenHueTo: [n] [setPenHue :n]
define setPenShadeTo: [n] [setPenShade :n]
define penSize: [n] [setPenSize (max 1 (min 500 :n))]

; ******* Sensing *******

; mouseX, mouseY, mousePressed, and soundLevel are Logo reporters

define mousePressed [] [output mouseIsDown]
 
to handle-keystrokes
    let [k keystroke]
    if empty? :k [stop]
    dolist [o fput stage sprites] [
        talkto :o
        dolist [scr scripts] [
            if (first first :scr) = "KeyEventHatMorph [
                if :k = (asciiForKeyname (item 2 first :scr)) [ignore start-script :o :scr true]
    ]]]
end

to keyPressed: :keyName
    let [k asciiForKeyname :keyName]
    if (and (:k > 64)(:k < 91)) [make "k (:k + 32)]  ; convert letters to lower case
    output keydown? :k
end

to asciiForKeyname :keyName
    if (count :keyName) = 1 [output ascii :keyName]
    if :keyName = "enter [output 10]
    if :keyName = "|left arrow| [output 28]
    if :keyName = "|right arrow| [output 29]
    if :keyName = "|up arrow| [output 30]
    if :keyName = "|down arrow| [output 31]
    if :keyName = "space [output 32]
    output -1
end

to handle-mouseclicks
    let [p mouseClick]
    if empty? :p [stop]
    dolist [o lput stage sprites] [
        talkto :o
        if (isShowing :o) [
            if (containsPoint? (item 1 :p)(item 2 :p)) [
                dolist [scr scripts] [
                    if (first first :scr) = "MouseClickEventHatMorph [ignore start-script :o :scr false]]
                stop
    ]]]
end

to touching: :thing
    if "mouse = :thing [output containsPoint? mouseX mouseY]
    if "edge = :thing [
        if %left < screenLeft [output true]
        if %top < screenTop [output true]
        if %right > screenRight [output true]
        if %bottom > screenBottom [output true]
        output false]
    if sprite? :thing [
        if (and (isShowing who) (isShowing :thing)) [
            if (touchingSprite? :thing) [output true]]]
    output false
end

define touchingColor: [c] [output touchingColor? :c]
define color:sees: [c1 c2] [output colorTouchingColor? :c1 :c2]

to distanceTo: :thing
    let [
        p mouseOrSpritePosition :thing
        dx xpos - (first :p)
        dy ypos - (last :p)]
    output sqrt (:dx * :dx) + (:dy * :dy)
end

define timerReset [] [make "<basetime> %timer]
define timer [] [output (%timer - :<basetime>) / 1000]
define isLoud [] [output soundLevel > 35]

define sensorPressed: [s] [output (sensor: :s) < 10]
to sensor: :s
    if (number? :s)   [output getSensorValue :s]
    if (:s = "slider) [output getSensorValue 1]
    if (:s = "light)  [output getSensorValue 2]
    if (:s = "sound)  [output getSensorValue 3]
    if (:s = "|button pressed|) [output getSensorValue 4]
    if (or (strequ "A first :s) (strequ "A last :s)) [output getSensorValue 5]
    if (or (strequ "B first :s) (strequ "B last :s)) [output getSensorValue 6]
    if (or (strequ "C first :s) (strequ "C last :s)) [output getSensorValue 7]
    if (or (strequ "D first :s) (strequ "D last :s)) [output getSensorValue 8]
    output 0
end

to getAttribute:of: :attr :obj
    if not (or (stage = :obj)(sprite? :obj)) [output 0]
    let [
        me who
        result []
        vdict []]
    talkto :obj
    if (stage = :obj) [
        if (strequ :attr "|background #|)    [make "result backgroundIndex]
        if (strequ :attr "volume)                    [make "result volume]
    ]
    if (sprite? :obj) [
        if (strequ :attr "|x position|)    [make "result xpos]
        if (strequ :attr "|y position|)    [make "result ypos]
        if (strequ :attr "direction)        [make "result heading]
        if (strequ :attr "|costume #|)    [make "result costumeIndex]
        if (strequ :attr "size)                    [make "result scale]
        if (strequ :attr "volume)                [make "result volume]
    ]
    talkto :me
    if (not empty? :result) [output :result]

    ; look up :attr as a variable
    make "vdict (get :obj "vars)
    if not list? (get :vdict :attr) [output (get :vdict :attr)] ; local var
    make "vdict (get stage "vars)]
    if not list? (get :vdict :attr) [output (get :vdict :attr)] ; global var
    output :result
end

; ******* Variables *******

define getVar: [n] [output readVariable :n]
define getUserVar: [n] [output readVariable :n]

to readVariable :vname
    let [vdict vardictfor :vname]
    output get :vdict :vname
end

to changeVariable :vname :op :val
    let [vdict vardictfor :vname]
    ifelse (or (:op = "set:to:)(:op = "setVar:to:))
        [put :vdict :vname :val]
        [put :vdict :vname (coerceToNumber (get :vdict :vname) + (coerceToNumber :val))]
end

; answer the vars object (for the current sprite or the stage) that defines the given variable
; if the variable is not found in either the spite's or stage's variables, define
; it as a stage variable (i.e. as a global)
to vardictfor :vname
    let [vdict (get who "vars)]
    if not list? (get :vdict :vname) [output :vdict]
    make "vdict (get stage "vars)
    if list? (get :vdict :vname) [put :vdict :vname 0]    ; auto-define the variable as a global
    output :vdict
end

to showVariable: :varName
    let [wlist watchersFor: :varName]
    if ((count :wlist) = 0) [make "wlist (list createWatcherFor :varName)]
    dolist [w :wlist][showWatcher :w]
    redrawall
end

to hideVariable: :varName
    dolist [w watchersFor: :varName][hideWatcher :w]
    redrawall
end

to watchersFor: :varName
    let [result []]
    dolist [w sprites] [
        if (watcher? :w) [
            if ((get :w "op) = "getVar:) [
                if ((get :w "param) = :varName) [
                    make "result (lput :w :result)]]]]
    output :result
end

to createWatcherFor :varName
    if (string? :varName) [make "varName intern :varName]
    let [w newVarWatcher :varName title string :varName]
    if (localVar? :varName) [make "title (word (word name "| |) :title)]
    setWatcherXY :w 10 findYForNewWatcher
    setWatcherColorAndLabel :w (newcolor 243 118 29) :title
    put :w "target who
    put :w "op "getVar:
    put :w "param :varName
    setsprites (fput :w sprites)
    output :w
end

to localVar? :varName
    let [vdict (get who "vars)]
    output not list? (get :vdict :varName) ; found varName in sprite's local variable dictionary
end

to findYForNewWatcher
    let [newY 35]
    dolist [w sprites] [
        if (watcher? :w) [
            if ((watcherY :w) + 25) > :newY [make "newY ((watcherY :w) + 25)]]]
    if (:newY > 360) [make "newY 360]
    output :newY
end

; ******* Lists *******

to contentsOfList: :listName
    let [lists listvarsFor :listName]
    output listContents (get (listvarsFor :listName) :listName)
end

to append:toList: :val :listName
    let [
        lists listvarsFor :listName
        newList []]
    make "newList (lput (asListElement: :val) (get :lists :listName))
    put :lists :listName :newList
    updateWatcher :listName :newList (count :newList)
end

to deleteLine:ofList: :index :listName
    let [lists listvarsFor :listName
         i 0
         newList []]
    if (:index = "all) [
        put :lists :listName :newList
        updateWatcher :listName :newList "none
        stop]
    if not (:i = (count (get :lists :listName))) [
        make "i compute-index :index :listName]
    if (:i = 0) [
        updateWatcher :listName (get :lists :listName) :i
        stop]
    make "newList (removeitempos :i (get :lists :listName))
    put :lists :listName :newList
    if (:i < ((count :newList) + 1)) [updateWatcher :listName :newList :i]
    if (:i > (count :newList)) [updateWatcher :listName :newList (:i - 1)]
end

to insert:at:ofList: :val :index :listName
    let [lists listvarsFor :listName
         len count (get :lists :listName)
         i compute-index :index :listName
         newList []]
    if (:index = "last) [make "i :len + 1]
    if (:index = "any) [make "i int(rand * (:len + 1)) + 1]
    if (:i = 0) [make "i 1]
    make "newList (insert (get :lists :listName) :i (asListElement: :val))
    put :lists :listName :newList
    updateWatcher :listName :newList :i
end

to setLine:ofList:to: :index :listName :val
    let [lists listvarsFor :listName
         i compute-index :index :listName]
    if (:i = 0) [stop]
    setitem :i (get :lists :listName) (asListElement: :val)
    updateWatcher :listName (get :lists :listName) :i
end

to getLine:ofList: :index :listName
    let [lists listvarsFor :listName
         i compute-index :index :listName
         w (get (get (listowner :listName) "listwatchers) :listName)]
    if not (:w = []) [highlightListWatcherIndex :w :i]
    if (:i = 0) [output "||]
    output item :i (get :lists :listName)
end

to lineCountOfList: :listName
    let [lists listvarsFor :listName]
    output count (get :lists :listName)
end

; following gets the listvars object for either the current sprite or the stage
to listvarsFor :listName
    if (hasKey listvars :listName) [output listvars]
    output get stage "listvars]
end

to updateWatcher :listName :newList :i
    let [w (get (get (listowner :listName) "listwatchers) :listName)]
    if (:w = []) [stop]
    setListWatcherList :w :newList
    if not (:i = "none) [highlightListWatcherIndex :w :i]
end

to listowner :listName
    if (hasKey listvars :listName) [output who]
    output stage
end

to compute-index :index :listName
    let [len count (get (listvarsFor :listName) :listName) i 0]
    if (:index = "last) [output :len]
    if (:index = "any) [output int(rand * :len) + 1]
    make "i round :index
    if (or (:i < 1)(:i > (:len + 1))) [output 0]
    output :i
end

to list:contains: :listName :val
    output member? :val (get (listvarsFor :listName) :listName)
end

to asListElement: :val
    if (false = :val) [output "0]
    if (true = :val) [output "1]
    if (number? :val) [
        if ((int :val) = :val) [output string :val]]  ; use integer string
    output :val
end

; ******* Strings *******

to concatenate:with: :s1 :s2
    output word :s1 :s2
end

to letter:of: :i :s
    if (not string? :s) [make "s string :s]
    if (strequ :i "first) [make "i 1]
    if (strequ :i "last) [make "i (count :s)]
    if (strequ :i "any) [make "i int(rand * (count :s)) + 1]
    if (string? :i) [make "i coerceToNumber :i]
    if (not number? :i) [make "i 0]
    make "i round :i
    if (or (:i < 1)(:i > (count :s))) [output "||]
    output item :i :s
end

to stringLength: :s
    if (not string? :s) [make "s string :s]
    output count :s
end

define answer [] [output lastAnswer]

; ******* Motor *******

define motorOnFor:elapsed:from: [secs] [timedCommand :secs [] []]
define allMotorsOn [] []
define allMotorsOff [] []
define startMotorPower: [power] []
define setMotorDirection: [direction] []

; This file defines the structure of a sprite and how to read in a Scratch project.
; The entry points are sprite, open, and openurl.

to sprite-startup
    ; builtin sprite fields: xpos ypos costume
    let [fields [name costumes sounds scripts vars listvars listwatchers midichan volume cindex]]
    dolist [i (se :fields)] [
        define :i [] (se [output get who] quote :i)
        define (word "set :i) [val] (se [put who] quote :i [:val])]
    make "<tempo> 60
end

; lookup a sprite by name
to sprite :name
    if :name = get stage "name [output stage]
    dolist [spr sprites] [if :name = get :spr "name [output :spr]]
    error (se [no sprite named] :name)
end

to open :projname
    install-objtable readprojfile (word :projname ".sb)
end

to openold :projname
    install-objtable readprojfile (word :projname ".scratch)
end

to openurl
    install-objtable readprojurl
end

to install-objtable :objtable
    clearall
    make "<tempo> 60
    setsprites []
    dolist [entry :objtable] [
        if (or ((item 2 :entry) = 124) ((item 2 :entry) = 125)) [add-extracted-object :entry]
        if ((item 2 :entry) = 155) [init-watcher :entry]
    ]
    dolist [entry :objtable] [
        if ((item 2 :entry) = 175) [init-list-watcher :entry]
    ]
    redrawall
    timerReset
end

; add a sprite/stage extracted from the given table entry
to add-extracted-object :o
    let [
        spr item 1 :o
        id item 2 :o
        version item 3 :o
        pos item 4 :o
        cost extract-costume (item 15 :o)
        flags item 8 :o
        sname item 10 :o
        sscale item 1 item 17 :o
        degrees item 18 :o
        rstyle item 19 :o]
    talkto :spr
    setname :sname
    setcostumes extract-costume-list :o
    setsounds extract-sounds :o
    setscripts extract-scripts :o
    setvars extract-variables :o
    setcostume (item 2 :cost) (item 3 :cost) (item 4 :cost)
    setvolume 100
    setDraggable false
    setcindex []
    setlistvars []
    setlistwatchers makelist 0
    if :id = 124 [    ; this object is a sprite
        setscale :sscale
        if (logand :flags 1) = 1 [hide]
        setheading :degrees + 90
        setrotationstyle stylenum :rstyle
        setx (item 1 :pos) + (item 3 :cost) - 240
        sety 180 - ((item 2 :pos) + (item 4 :cost))
        if (:version > 1) [
            setvolume (item 20 :o)
            setDraggable (item 22 :o)]
        if (:version > 2) [setlistvars extract-listvars (item 24 :o)]
    ]
    if :id = 125 [    ; this object is the stage
        setstage :spr
        setsprites []
        dolist [obj (item 6 :o)][
            if sprite? :obj [setsprites (lput :obj sprites)]
            if watcher? :obj [setsprites (lput :obj sprites)]]
        if (:version > 3) [
            setvolume (item 21 :o)
            make "<tempo> (item 22 :o)]
        if (:version > 4) [setlistvars extract-listvars (item 24 :o)]
    ]
end

; extract a list of costumes from a sprite/stage object table entry
to extract-costume-list :x
    let [
        medialist item 14 :x
        result []]
    dolist [m :medialist] [
        if (item 2 :m) = 162 [make "result lput (extract-costume :m) :result]]
    output :result
end

; extract a costume record from the given ImageMedia object table entry
; output a 4-typle: (<name><image><rotCenter x><rotCenter y>)
to extract-costume :m
    let [
        name item 4 :m
        img item 5 :m
        rotCenter item 6 :m]
    if (item 3 :m) > 2 [ ; ImageMedia version 4 or later, use compositeForm if not nil
        if (not list? (item 8 :m)) [ ; image was jpeg compressed; expand and save
                make "img jpegDecode (item 8 :m)
                setitem 5 :m :img
                setitem 8 :m []]]
    if (item 3 :m) > 3 [ ; ImageMedia version 4 or later, use compositeForm if not nil
        if (not list? (item 9 :m)) [make "img (item 9 :m)]]
    output (se :name :img (item 1 :rotCenter)(item 2 :rotCenter))
end

; extract a list of sounds from a sprite/stage object table entry
; each sound is a pair (<name><sound>)
to extract-sounds :o
    let [
        medialist item 14 :o
        result []]
    dolist [m :medialist] [
        if (item 2 :m) = 164 [
            let [
                name item 4 :m
                snd item 5 :m]
            make "result lput (se :name :snd) :result]]
    output :result
end

; extract a list of scripts from a sprite/stage object table entry
to extract-scripts :o
    let [
        slist item 12 :o
        result []]
    dolist [s :slist] [make "result lput (item 2 :s) :result]
    output :result
end

to stylenum :styleName
    if (:styleName = "normal) [output 0]
    if (:styleName = "leftRight) [output 1]
    if (:styleName = "none) [output 2]
    output 0
end

; extract the variables for the given sprite/stage object table entry
; return an empty list whose property list contains the variable bindings.
to extract-variables :o
    let [
        varlist item 11 :o
        i 1
        result makelist 0]
    repeat ((count :varlist) / 2) [
        put :result (intern item :i :varlist) (item :i + 1 :varlist)
        make "i :i + 2
    ]
    output :result
end

; extract the list variables for the given array of (name, list) pairs
; return an empty list whose property list contains the list variable bindings.
to extract-listvars :pairs
    let [
        i 1
        vname []
        val []
        result makelist 0]
    repeat ((count :pairs) / 2) [
        make "vname (intern item :i :pairs)
        make "val (item 13 (item :i + 1 :pairs))
        put :result :vname :val
        make "i :i + 2
    ]
    output :result
end

; initialize the Watcher for the given object table entry
to init-watcher :o
    let [
        w item 1 :o
        version item 3 :o
        box item 4 :o
        title item 17 :o
        readout item 18 :o
        readoutFrame item 19 :o
        readoutBox item 4 :readoutFrame
        slider item 20 :o
        target item 14 :readout
        op item 15 :readout
        param item 17 :readout]
    if (string? :param) [make "param intern :param]
    setWatcherXY :w ((item 1 :box) + 1) ((item 2 :box) + 26)
    setWatcherColorAndLabel :w (item 7 :readoutFrame) (item 12 :title)
    if (:version > 3) [setWatcherSliderMinMax :w (item 24 :o) (item 25 :o)]
    ifelse ((count :slider) > 0)
        [setWatcherMode :w 2]
        [if ((item 4 :readoutBox) - (item 2 :readoutBox)) > 14 [setWatcherMode :w 3]]
    put :w "target :target
    put :w "op :op
    put :w "param :param
end

; initialize the ListWatcher for the given object table entry
to init-list-watcher :o
    if not (sprite? (item 5 :o)) [stop]    ; do nothing if owner is nil (i.e. watcher is not showing)
    let [
        w newListWatcher
        version item 3 :o
        box item 4 :o
        listName item 12 :o
        listContents item 13 :o
        listTarget item 14 :o]
    put (get :listTarget "listwatchers) intern :listName :w
    setListWatcherXY :w ((item 1 :box) + 1) ((item 2 :box) + 26)
    setListWatcherWidthHeight :w ((item 3 :box) - (item 1 :box)) ((item 4 :box) - (item 2 :box))
    if not (:listTarget = stage) [make "listName (word (get :listTarget "name) "| | :listName)]
    setListWatcherLabel :w :listName
    setListWatcherList :w :listContents
end

to startup
    load "sprite
    load "thread
    load "commands
    sprite-startup
    thread-startup
    make "cycle 0
    ifelse applet?
        [openurl]
        [open "midiTest]
    if autostart? [greenflag]
end

to greenflag
    stopAll
    dolist [o fput stage sprites] [
        talkto :o
        dolist [scr scripts] [
            if (first :scr) = [EventHatMorph Scratch-StartClicked] [ignore start-script :o :scr false]
        ]
    ]
    interact
end

to interact
    redrawall
    requestFocus
    loop [runstep]
end

to runstep
    let [t %timer]
    handle-keystrokes
    handle-mouseclicks
    step-all-threads
    updatePenTrails
    updateWatchers
    updateListWatchers
    redraw
    make "t %timer - :t
    if :t < 30 [mwait 30 - :t] ; limit speed to 33 frames/sec
end

to updateWatchers
    dolist [w sprites] [
        if (watcher? :w) [
            let [
                op (get :w "op)
                param (get :w "param)
                val 0]
            talkto (get :w "target)
            ifelse empty? :param
                [make "val run (list :op)]
                [make "val run (list :op (quote :param))]
            setWatcherText :w :val]]
end

to updateListWatchers
    make "cycle ((:cycle + 1) % 5)
    if (:cycle = 0) [
        dolist [w sprites] [
            if (listWatcher? :w) [clearListWatcherHighlights :w]]]
end
        
; for debugging; run a script to completion on the current sprite
to do :cmds
    stopAll
    ignore start-thread who :cmds
    loop [
        if (count :<threads>) = 0 [stop]
        runstep]
end

; A thread is a list:
;
;    1 running?        becomes false when thread stops
;    2 owner            script owner (a sprite or the stage)
;    3 oldstate        state saved when a block runs a sublist of commands
;    4 cmds            current command list
;    5 ip            index of the current command in cmds
;    6 end-msecs        used by timed commmads such as glide
;    7 tmp            used by timed commmads and repeat
;
; <threads> is a global list of running threads
; <current-thread> is the thread currently being run by step-thread
; <yield?> is set to true when the current thread wishes to yield
; <stopall> is set to true when the stopall command is invoked

to thread-startup
    stop-all-threads
    let [ fields [running? owner oldstate cmds ip end-msecs tmp]
                field "]
    dotimes [i count :fields] [
        make "field nth :i :fields
        define word "thread- :field [] (se [output nth] :i [:<current-thread>])
        define word "set-thread- :field [v] (se [setnth] :i [:<current-thread> :v])
    ]
end

to stop-all-threads
    if (name? "<threads>) [
        dolist [thrd :<threads>][abort-thread :thrd]]
    make "<threads> []
    make "<stopall> true
end

to abort-thread :<current-thread>
    stop-thread
    if thread-ip > count thread-cmds [stop]
    let [
        cmd item thread-ip thread-cmds
        chan get thread-owner "midichan]
    if list? thread-tmp [stop]
    if list? :chan [stop]
    if ((first :cmd) = "noteOn:duration:elapsed:from:) [midinoteoff :chan thread-tmp]
    if ((first :cmd) = "drum:duration:elapsed:from:) [midinoteoff 10 thread-tmp]
    if ((first :cmd) = "doPlaySoundAndWait) [stopSound thread-tmp]
end

to stop-thread
    set-thread-running? false
    let [topCmds item 4 (thread-top :<current-thread>)]
    if not empty? :topCmds [put (first :topCmds) "thread []]
end

; return the thread for the top-level command list for this thread
to thread-top :thrd
    loop [
        if empty? (item 3 :thrd) [output :thrd]
        make "thrd (item 3 :thrd)]
end

; start a thread for a hat block and return the thread object
to start-script :sprite :hat :isKeyEvent
    let [cmdList butfirst :hat]
    if empty? :cmdList [output [false]]
    let [oldThrd get (first :cmdList) "thread]
    if not empty? :oldThrd [
        if (first :oldThrd) [ ; the thread for this hat is running
            ifelse :isKeyEvent
                [output [false]]
                [abort-thread :oldThrd]]]
    let [newThrd start-thread :sprite :cmdList]
    put (first :cmdList) "thread :newThrd
    output :newThrd
end

; start a thread and return the thread object
to start-thread :sprite :cmds
    let [thrd (list true :sprite [] :cmds 1 [] [])]
    make "<threads> lput :thrd :<threads>
    output :thrd
end

; step each thread in <threads> and remove any threads that are no longer running
to step-all-threads
    let [oldThreads :<threads>]
    make "<threads> []
    make "<stopall> false
    dolist [thrd :oldThreads] [
        carefully [step-thread :thrd][print "error abort-thread :thrd]
;;;xxx    step-thread :thrd
        if :<stopall> [
            dolist [t :oldThreads][abort-thread :t]
            stop]]
    dolist [thrd :oldThreads] [if first :thrd [make "<threads> lput :thrd :<threads>]]
end

; step a thread until it yields
to step-thread :<current-thread>
    if not thread-running? [stop]
    talkto thread-owner
    let [<yield?> false]
    loop [
        if thread-ip > count thread-cmds [end-list]
        if :<yield?> [stop]
        run eval-all-args (item thread-ip thread-cmds)
        updatePenTrails
        if :<yield?> [stop]
        set-thread-ip thread-ip + 1]
end

; run the given list of commands (used by control structure commands)
to run-list :cmdList
    set-thread-oldstate copylist :<current-thread>
    set-thread-cmds :cmdList
    set-thread-ip 0
    set-thread-end-msecs []
    set-thread-tmp []
end

to end-list
    ifelse empty? thread-oldstate
        [stop-thread yield]
        [ let [oldstate thread-oldstate]
            set-thread-oldstate (item 3 :oldstate)
            set-thread-cmds (item 4 :oldstate)
            set-thread-ip (item 5 :oldstate)
            set-thread-end-msecs (item 6 :oldstate)
            set-thread-tmp (item 7 :oldstate)
            if thread-ip > count thread-cmds [end-list stop]
            let [cmd first (item thread-ip thread-cmds)]
            if (or (:cmd = "doForever)(:cmd = "doForeverIf)(:cmd = "doRepeat)(:cmd = "doUntil)) [yield]
        ]
end

; if the argument is a list, evaluate it. otherwise, return it
to eval-arg :arg
    if number? :arg [output :arg]
    if quoted? :arg [output :arg]
    if string? :arg [output quote :arg]
    if color? :arg [output :arg]
    if sprite? :arg [output :arg]
    if list? :arg [
        if ((count :arg) = 1) [
            if (list? first :arg) [make "arg first :arg]]
        output eval-expression eval-all-args :arg]
    if :arg = true [output :arg]
    if :arg = false [output :arg]
    output quote :arg
end

; evaluate an expression whose arguments have already been evaluted
to eval-expression :expr
    if (count :expr) = 0 [output :expr]
    let [op item 1 :expr]
    if (count :expr) = 3 [
        if (count first :expr) < 3 [
            let [
                    op item 1 :expr
                    arg1 eval-arg item 2 :expr
                    arg2 eval-arg item 3 :expr]
            if (member? :op [< = >]) [output eval-comparision :expr]

            make "arg1 coerceToNumber :arg1
            make "arg2 coerceToNumber :arg2
            if "+ = :op [output :arg1 + :arg2]
            if "- = :op [output :arg1 - :arg2]
            if "* = :op [output :arg1 * :arg2]
            if "/ = :op [output :arg1 / :arg2]
            if "\\ = :op [
                let [n :arg1 % :arg2]
                if :n < 0 [make "n :n + abs :arg2]
                output :n]
            if "& = :op [output (and :arg1 :arg2)]
            if (char 124) = :op [output (or :arg1 :arg2)]]]    ; 124 is | (vertical bar)

    let [v run :expr]
    if (string? :v) [make "v quote :v]
    output :v
end

to eval-comparision :expr
    let [
        op item 1 :expr
        arg1 eval-arg item 2 :expr
        arg2 eval-arg item 3 :expr]

    if quoted? :arg1 [make "arg1 unquote :arg1]
    if quoted? :arg2 [make "arg2 unquote :arg2]
    if isNumberFormat :arg1 [make "arg1 coerceToNumber :arg1]
    if isNumberFormat :arg2 [make "arg2 coerceToNumber :arg2]
    if (and (string? :arg1)(string? :arg2)) [
        if "< = :op [output (strcmp :arg1 :arg2) < 0]
        if "= = :op [output (strcmp :arg1 :arg2) = 0]
        if "> = :op [output (strcmp :arg1 :arg2) > 0]]
    if (and (string? :arg1)(number? :arg2)) [
        ifelse isNumberFormat :arg1
            [make "arg1 coerceToNumber :arg1]
            [output false]]
    if (and (number? :arg1)(string? :arg2)) [
        ifelse isNumberFormat :arg2
            [make "arg2 coerceToNumber :arg2]
            [output false]]

    if "< = :op [output :arg1 < :arg2]
    if "= = :op [output :arg1 = :arg2]
    if "> = :op [output :arg1 > :arg2]
end

to coerceToNumber :o
    if number? :o [output :o]
    if quoted? :o [make "o unquote :o]
    if string? :o [
        if (count :o) = 0 [output 0]
        ifelse isNumberFormat :o
            [output 0 + :o]
            [output 0]]
    output :o
end

; return a copy of the given command with all of its arguments evaluated
; however, do not evalute the arguments if the command is a control structure
to eval-all-args :cmd
    let [new-cmd copylist :cmd]
    if is-control? :cmd [output :new-cmd]
    dotimes [i (count :cmd) - 1] [
        setitem :i + 2 :new-cmd (eval-arg item :i + 2 :cmd)]
    if (count :new-cmd) > 0 [coerce-number-args :new-cmd]
    output :new-cmd
end

; coerce selected arguments of the given command to numbers if necessary
to coerce-number-args :cmd
    let [op first :cmd]

    ; coerce all arguments of these commands to numbers
    if member? :op [
        forward: turnRight: turnLeft: gotoX:y: glideSecs:toX:y:elapsed:from: changeXposBy: xpos: changeYposBy: ypos:
        setSizeTo: goBackByLayers:
        drum:duration:elapsed:from: rest:elapsed:from: noteOn:duration:elapsed:from:
        midiInstrument: changeVolumeBy: setVolumeTo: changeTempoBy: setTempoTo:
        changePenHueBy: setPenHueTo: changePenShadeBy: setPenShadeTo: changePenSizeBy: penSize: changeSizeBy:
        wait:elapsed:from: randomFrom:to: rounded] [
            dotimes [i count :cmd] [
                if :i > 0 [setnth :i :cmd (coerceToNumber nth :i :cmd)]]]

    ; coerce the last argument of these commands to a number
    if member? :op [
        computeFunction:of:
        say:duration:elapsed:from: think:duration:elapsed:from:
        changeGraphicEffect:by: setGraphicEffect:to:] [
            let [i count :cmd]
            setitem :i :cmd (coerceToNumber item :i :cmd)]
end

define yield [] [make "<yield?> true]

; ******* control structures *******

; return true if the given command is a control structure
; (i.e. it decided when and how to evalutate it's arguments)
to is-control? :cmd
    if (count :cmd) = 0 [output false]
    output member? first :cmd [doForever doForeverIf doIf doIfElse doRepeat doUntil doWaitUntil]
end

to is-true? :expr
    if :expr = "false [output false]
    output eval-arg :expr
end

to doForever :cmdList
    run-list :cmdList
end

to doForeverIf :expr :cmdList
    ifelse is-true? :expr
        [run-list :cmdList]
        [yield]
end

to doIf :expr :cmdList
    if is-true? :expr [
        set-thread-ip thread-ip + 1
        run-list :cmdList]
end

to doIfElse :expr :trueCmdList :falseCmdList
    set-thread-ip thread-ip + 1
    ifelse is-true? :expr
        [run-list :trueCmdList]
        [run-list :falseCmdList]
end

to doRepeat :count :cmdList
    if empty? thread-tmp [set-thread-tmp coerceToNumber eval-arg :count]
    if thread-tmp < 1 [set-thread-tmp [] stop]    ; repeat finished
    set-thread-tmp thread-tmp - 1
    run-list :cmdList
end

to doUntil :expr :cmdList
    if not is-true? :expr [run-list :cmdList]
end

define doWaitUntil [expr] [if not is-true? :expr [yield]]

define doReturn [] [stop-thread yield]

to doAsk :question
    if list? thread-tmp [
        if askPromptShowing? [yield stop]
        ifelse (and (sprite? thread-owner) (not thread-owner = stage) (isVisible thread-owner))
            [talkto thread-owner
             askbubble :question
             showAskPrompt "||]
            [showAskPrompt :question]
        set-thread-tmp "askInProgress
    ]
    if askPromptShowing? [yield stop]
    askbubble "||
    set-thread-tmp []
end