Root functor: Lift.oz

### Root functor: `Lift.oz`

Source File

>     functor

>     require
>        DemoUrls(image)

>     prepare
>        ImageNames = {Map [upF downF upE downE lift liftUp liftDown]
>                      fun {$ A}
>                         DemoUrls.image#'lift/'#A#'.xbm'
>                      end}

>     import
>        Tk
>        TkTools
>        Application

>     define
>        %%
>        %% Lift Simulation -- Randomised and Interactive Lift Requests
>        %%
>        %% The Scheduling Algorithm is taken from the book
>        %% 'Concurrent Programming in Erlang', Chapter 11: Real-Time Control
>        %%

>        %%
>        %% Colors
>        %%
>        [BGColor FGColor FloorsColor KnobColor NumColor]
>        = if Tk.isColor then
>             [steelblue bisque lightsteelblue blue 'IndianRed']
>          else
>             [grey55 grey55 grey55 black black]
>          end

>        %%
>        %% Parameters
>        %%

>        NumFloors  = 5          %% number of floors
>        NumLifts   = 3          %% number of lifts

>        CallMode   = call       %% lift called from floor
>        SendMode   = send       %% lift sent from inside
>        DelayLift  = 2500       %% delay between simulated lift calls
>        DelayOpen  = 500        %% delay for opening doors
>        DelayStep  = 120        %% delay for lift speed

>        %%
>        %% Images
>        %%

>        Images = {TkTools.images ImageNames}

>        Bold   = {New Tk.font tkInit(family:courier weight:bold size:~24)}

>        %%
>        %% constants and procedures for the graphical representation
>        %%

>        FloorDelta = 10
>        FloorSteps = 7
>        FloorLeft  = 10
>        FloorRight = 220
>        FloorSize  = FloorDelta * FloorSteps
>        Height     = FloorSize * NumFloors - 15
>        Width      = 230
>        LeftMost   = 110
>        Bound      = 3
>        LiftDelta  = 38

>        fun {Pos2Floor Y} (Height - Y) div FloorSize + 1 end
>        fun {Floor2Pos N} Height - (N-1) * FloorSize end

>        GroundLevel = {Floor2Pos 1} - LiftDelta

>        %%
>        %% Random Number Generator (alternatively, see OS.rand)
>        %%

>        class Randomizer from BaseObject
>           prop
>              final

>           feat
>              a: 24298
>              b: 9991
>              c: 199017

>           attr
>              seed:24676

>           meth next(?N)
>              S=@seed
>           in
>              N={IntToFloat S}/{IntToFloat self.c}
>              seed <- (self.a * S + self.b) mod self.c
>           end

>           meth uniform(A B ?R)
>              N in Randomizer, next(N) R=N*(B-A)+A
>           end
>        end

>        Random = {New Randomizer noop}

>        fun {RandomChoice N M}
>           {FloatToInt {Random uniform({IntToFloat N}
>                                       {IntToFloat M}
>                                       $)}}
>        end

>        fun {RanChoiceFloor}
>           {RandomChoice 1 NumFloors}
>        end

>        fun {RanChoiceBin X Y}
>           if {RandomChoice 0 1}==1 then X else Y end
>        end

>        %%
>        %% Compute the cost of a request from floor Floor with direction
>        %% Dir for a lift at floor At with current task stack CurrSch,
>        %% and also return the corresponding new schedule NewSch.
>        %%

>        CostWait = 5 %% cost estimate for opening and closing the doors

>        fun {Insert Task At CurrSch}
>           {Cost Task At CurrSch _} % ignore cost
>        end

>        proc {Cost Task At CurrSch Offer NewSch}
>           goto(To _ Dir _) = Task
>        in
>           case CurrSch
>           of nil then
>              Offer  = {Abs At-To}
>              NewSch = [Task]

>           [] CurrTask|RCurrSch then
>              goto(CurrTo _ _ _) = CurrTask
>           in
>              if At=<To
>                 andthen To=<CurrTo
>                 andthen Dir==up
>              then
>                 Offer  = {Abs At-To}
>                 NewSch = Task|CurrSch

>              elseif CurrTo=<To
>                 andthen To=<At
>                 andthen Dir==down
>              then
>                 Offer  = {Abs At-CurrTo}
>                 NewSch = Task|CurrSch

>              else
>                 ROffer RNewSch
>              in
>                 {Cost Task CurrTo RCurrSch ROffer RNewSch}
>                 Offer  = {Abs At-CurrTo} + CostWait + ROffer
>                 NewSch = CurrTask|RNewSch
>              end
>           end
>        end

>        %%
>        %% Interactively send the lift somewhere
>        %%

>        class Press from BaseObject

>           prop final
>           attr val

>           meth init(Choice)
>              val <- Choice
>           end
>           meth press(N)
>              @val = N
>           end
>        end

>        proc {PopChoice View P ?Choice}
>           Select = {New Press init(Choice)}
>           proc {Button N}
>              At = NumFloors - N + 1
>              Y  = P + LiftDelta - At * 8
>              Knob = {New Tk.canvasTag tkInit(parent:View)}
>              Num  = {New Tk.canvasTag tkInit(parent:View)}
>           in
>              {View tk(crea oval 92 Y 100 Y+5 tag:Knob fill:KnobColor)}
>              {View tk(crea text 85 Y tag:Num text:At fill:NumColor)}
>              {Knob tkBind(event:'<1>' action: Select # press(At))}

>              thread
>                 {Wait Choice}
>                 {Knob tkClose}
>                 {Num  tkClose}
>              end
>           end
>        in
>           {For 1 NumFloors 1 Button}
>        end

>        %%
>        %% Individual Lift Object
>        %%

>        class Lift from Tk.canvasTag

>           prop
>              locking
>              final

>           feat
>              View
>              PosX

>           attr
>              PosY     : GroundLevel
>              CurrFloor: 1
>              Agenda   : nil
>              State    : idle

>           meth init(L)
>              self.PosX   = {L join(self $)}
>              self.View   = L

>              Tk.canvasTag, tkInit(parent:L)
>              Lift, drawInit
>           end

>           meth request(Task ?Offer Cont)

>              lock
>                 ReqCost NewAgenda
>              in
>                 {Cost Task @CurrFloor @Agenda ReqCost NewAgenda}

>                 case @State
>                 of openDoor then
>                    %%
>                    %% guess a high delay dependent on current agenda
>                    %%
>                    Offer = ({Length @Agenda}+1)*1000
>                 else
>                    Offer = ReqCost
>                 end

>                 %%
>                 %% wait for release (false) or commit (true)
>                 %%
>                 if Cont then
>                    Agenda <- NewAgenda
>                    case @Agenda of [_] then
>                       case @State of openDoor
>                       then skip else Lift, proceed
>                       end
>                    else skip end
>                 end
>              end

>           end

>           meth moveBy(Y)
>              PosY      <- @PosY+Y
>              CurrFloor <- {Pos2Floor @PosY}
>              Tk.canvasTag, tk(move 0 Y)
>           end

>           meth proceed

>              if @Agenda==nil then
>                 State <- idle
>                 Lift, draw(lift)
>              else
>                 To      = @Agenda.1.1
>                 PosTo   = {Floor2Pos To}
>                 CurrPos = @PosY+LiftDelta
>              in
>                 Lift, draw(if To>@CurrFloor then liftUp
>                            elseif To<@CurrFloor then liftDown
>                            else lift end)

>                 if {Abs CurrPos-PosTo}<5 then
>                    Lift, reached
>                 elseif CurrPos>PosTo then
>                    Lift, moveBy(~FloorDelta)

>                    thread
>                       {Delay DelayStep}
>                       {self proceed}
>                    end

>                 else
>                    Lift, moveBy(FloorDelta)

>                    thread
>                       {Delay DelayStep}
>                       {self proceed}
>                    end
>                 end
>              end

>           end

>           meth reached

>              Mode Who RestAgenda
>           in

>              lock
>                 goto(_ Mode _ Who)|RestAgenda = @Agenda
>                 {self.View reached(@CurrFloor)}
>                 Agenda <- RestAgenda
>              end

>              if Mode==!CallMode then
>                 To
>                 CurrY = @PosY
>                 Num   = @CurrFloor
>              in
>                 State <- openDoor

>                 thread
>                    To = case Who of sim then
>                            {Delay DelayOpen}
>                            {RanChoiceFloor}
>                         elseof press then
>                            {PopChoice self.View CurrY}
>                         end
>                 end

>                 {Wait To}

>                 Agenda <- {Insert
>                            goto(To
>                                 SendMode
>                                 if To>Num then up else down end
>                                 Who)
>                            @CurrFloor
>                            @Agenda}
>              end
>              Lift, closeDoor

>           end

>           meth closeDoor
>              State <- idle
>              Lift, proceed
>           end

>           meth drawInit
>              {self.View
>               tk(crea image self.PosX+12 @PosY+12 image:Images.lift tag:self)}
>           end

>           meth draw(I)
>              Tk.canvasTag, tk(itemconf image:Images.I)
>           end
>        end

>        %%
>        %% request a lift
>        %%

>        local
>           fun {ListMin Xs}
>              case Xs of [X] then X
>              elseof (X#CX)|Xr then
>                 MXr#CXr = {ListMin Xr}
>              in
>                 if X<MXr then
>                    CXr = false % release
>                    X#CX        % current minimal offer
>                 else
>                    CX = false  % release
>                    MXr#CXr     % current minimal offer
>                 end
>              end
>           end
>        in
>           proc {Request Ls Task}
>              fun {DoReq L}
>                 O C
>              in
>                 thread
>                    {L request(Task O C)}
>                 end
>                 O#C
>              end
>           in
>              true = {ListMin {Map Ls DoReq}}.2 % commit
>           end
>        end

>        %%
>        %% Individual Floor Object
>        %%

>        class Floor from BaseObject

>           prop
>              final

>           feat
>              Num
>              PosY
>              View
>              Up UpTag
>              Down DownTag

>           meth init(L N)
>              self.Num  = N
>              self.PosY = {Floor2Pos N}
>              self.View = L
>              self.Down = N>1
>              self.Up   = N<NumFloors

>              Floor, drawText

>              if self.Up then
>                 Floor, drawButton(self.UpTag
>                                   35
>                                   self.PosY-15
>                                   upF
>                                   doUp(press))
>              end

>              if self.Down then
>                 Floor, drawButton(self.DownTag
>                                   55
>                                   self.PosY-15
>                                   downF
>                                   doDown(press))
>              end

>              Floor, show
>           end

>           meth doUp(Who)
>              if self.Up then
>                 Ms = {self.View members($)}
>              in
>                 Floor, draw(true false)  % up/empty
>                 {Request Ms goto(self.Num CallMode up Who)}
>              end
>           end

>           meth doDown(Who)
>              if self.Down then
>                 Ms = {self.View members($)}
>              in
>                 Floor, draw(false false)  % down/empty
>                 {Request Ms goto(self.Num CallMode down Who)}
>              end
>           end

>           meth reached
>              if self.Up then
>                 Floor, draw(true true)  % up/full
>              end
>              if self.Down then
>                 Floor, draw(false true) % down/full
>              end
>           end

>           meth show
>              {self.View
>               tk(crea line FloorLeft self.PosY FloorRight self.PosY)}
>           end

>           meth draw(Up Full)
>              if Up then
>                 if Full
>                 then {self.UpTag tk(itemconf image:Images.'upF')}
>                 else {self.UpTag tk(itemconf image:Images.'upE')}
>                 end
>              else
>                 if Full
>                 then {self.DownTag tk(itemconf image:Images.'downF')}
>                 else {self.DownTag tk(itemconf image:Images.'downE')}
>                 end
>              end
>           end

>           meth drawText
>              {self.View tk(crea text 15 self.PosY-17
>                            text: self.Num
>                            font: Bold
>                            tag : {New Tk.canvasTag tkInit(parent:self.View)}
>                            fill: blue)}
>           end

>           meth drawButton(Tag X Y I Action)
>              Tag = {New Tk.canvasTag tkInit(parent:self.View)}
>              {self.View tk(crea image X Y image:Images.I tag:Tag)}
>              {Tag tkBind(event:'<1>' action:proc {$} {self Action} end)}
>           end
>        end

>        %%
>        %% Lift Manager
>        %%

>        class LiftManager from Tk.canvas Time.repeat

>           prop
>              final

>           feat
>              Floors

>           attr
>              Members: nil
>              PosX   : LeftMost
>              Queue  : nil

>           meth init(parent:W floors:AllFloors)
>              self.Floors = AllFloors

>              Tk.canvas, tkInit(parent:     W
>                                width:      Width
>                                height:     Height
>                                relief:     sunken
>                                bd:         Bound
>                                background: FloorsColor)

>              Time.repeat, setRepAll(action:press delay:DelayLift)
>           end

>           meth join(L ?X)
>              X = @PosX
>              PosX <- X + LiftDelta
>              Members <- L|@Members
>           end

>           meth members($)
>              @Members
>           end

>           meth press
>              R={RanChoiceFloor}
>              Action = if R==NumFloors then doDown
>                       elseif R==1 then doUp
>                       else {RanChoiceBin doUp doDown}
>                       end
>           in
>              {{Nth self.Floors R} Action(sim)}
>           end

>           meth reached(N)
>              {{Nth self.Floors N} reached}
>           end

>           meth close
>              Time.repeat, stop
>              Tk.canvas,   tkClose
>           end
>        end

>        %%
>        %% Create Window and Lifts object as manager for group of Lift objects
>        %%

>        Top = {New Tk.toplevel tkInit(title:  'Oz Lifts'
>                                      delete: Application.exit # 0)}

>        BFrame = {New Tk.frame tkInit(parent:     Top
>                                      width:      20
>                                      background: BGColor)}

>        L1 = {New Tk.label tkInit(parent:     BFrame
>                                  text:       "automatic operation"
>                                  background: BGColor)}

>        L2 = {New Tk.label tkInit(parent:     Top
>                                  text:       "Press arrows for manual operation"
>                                  width:      30
>                                  background: BGColor)}

>        AllFloors  = {List.make NumFloors}
>        AllLifts   = {List.make NumLifts}

>        Lifts = {New LiftManager init(parent:Top floors:AllFloors)}

>        GoB   = {New Tk.label tkInit(parent:     BFrame
>                                     text:       " start "
>                                     relief:     raised
>                                     bd:         2
>                                     width:      9
>                                     background: FGColor)}

>        proc {AutoOn}
>           {GoB tk(conf text:" stop ")}
>           {GoB tkBind(action:AutoOff event:'<1>')}
>           {Lifts go}
>        end

>        proc {AutoOff}
>           {GoB tk(conf text:" start ")}
>           {GoB tkBind(action:AutoOn event:'<1>')}
>           {Lifts stop}
>        end

>        {GoB tkBind(action:AutoOn event:'<1>')}

>        {Tk.batch [pack(Lifts  padx:10 pady:20)
>                   pack(BFrame side:top)
>                   pack(GoB L1 side:left padx:2 expand:true)
>                   pack(L2     side:top pady:2)
>                  ]}

>        %%
>        %% Create lift and floor objects
>        %%

>        if NumFloors>=2 then

>           {List.forAllInd AllFloors
>            fun {$ N}
>               {New Floor init(Lifts N)}
>            end}

>           {ForAll AllLifts
>            fun{$}
>               {New Lift init(Lifts)}
>            end}

>        end

>     end