obliqlib3D/src/ObRealProp.m3


 Copyright (C) 1994, Digital Equipment Corporation                         
 Digital Internal Use Only                                                 
 All rights reserved.                                                      
                                                                           
 Last modified on Mon Sep 26 21:57:42 PDT 1994 by najork                   
       Created on Sat May 28 11:15:36 PDT 1994 by najork                   

MODULE ObRealProp;

IMPORT ObAnimHandle, ObAux, ObCommand, ObLib, ObLongReal, ObProp,
       ObProtoLoader, ObReal, ObValue, Obliq, Prop, ProxiedObj, RealProp,
       RealPropProxy, SynLocation;
*************************************************************************** Wrapper for RealProp.Name ***************************************************************************

TYPE
  Name = ObProp.Name BRANDED "ObRealProp.Name" OBJECT END;

PROCEDURE AddNameObj (pn : RealProp.Name) =
  <* FATAL ObValue.Error, ObValue.Exception *>
  BEGIN
    WITH obj = Obliq.ObjectClone (Obliq.Vals {NameProto}),
         raw = NEW (Name, what := "<a RealProp.Name>", po := pn) DO
      Obliq.ObjectUpdate (obj, "raw", raw);
      pn.proxy := NEW (ProxiedObj.Proxy, obj := obj);
    END;
  END AddNameObj;

PROCEDURE GetName (args    : ObValue.ArgArray;
                   idx     : INTEGER;
                   package : ObLib.T;
                   opCode  : ObLib.OpCode;
                   loc     : SynLocation.T) : RealProp.Name
    RAISES {ObValue.Error, ObValue.Exception} =
  BEGIN
    WITH raw = Obliq.ObjectSelect (args[idx], "raw") DO
      TYPECASE raw OF
      | Name (node) =>
        RETURN node.po;
      ELSE
        ObValue.BadArgType (idx, pkgname, package.name, opCode.name, loc);
        RETURN NIL;      (* ... only to suppress compiler warning *)
      END;
    END;
  END GetName;
*************************************************************************** Wrapper for RealProp.Val ***************************************************************************

TYPE
  Val = ObProp.Val BRANDED "ObRealProp.Val" OBJECT END;

PROCEDURE AddValObj (pv : RealProp.Val) =
  <* FATAL ObValue.Error, ObValue.Exception *>
  BEGIN
    WITH obj = Obliq.ObjectClone (Obliq.Vals {ValProto}),
         raw = NEW (Val, what := "<a RealProp.Val>", po := pv) DO
      Obliq.ObjectUpdate (obj, "raw", raw);
      pv.proxy := NEW (ProxiedObj.Proxy, obj := obj);
    END;
  END AddValObj;

PROCEDURE GetVal (args    : ObValue.ArgArray;
                  idx     : INTEGER;
                  package : ObLib.T;
                  opCode  : ObLib.OpCode;
                  loc     : SynLocation.T) : RealProp.Val
    RAISES {ObValue.Error, ObValue.Exception} =
  BEGIN
    WITH raw = Obliq.ObjectSelect (args[idx], "raw") DO
      TYPECASE raw OF
      | Val (node) =>
        RETURN node.po;
      ELSE
        ObValue.BadArgType (idx, pkgname, package.name, opCode.name, loc);
        RETURN NIL;      (* ... only to suppress compiler warning *)
      END;
    END;
  END GetVal;

PROCEDURE GetOverloadedVal (args    : ObValue.ArgArray;
                            idx     : INTEGER;
                            package : ObLib.T;
                            opCode  : ObLib.OpCode;
                            loc     : SynLocation.T) : RealProp.Val
    RAISES {ObValue.Error, ObValue.Exception} =
  BEGIN
    TYPECASE args[idx] OF
    | ObValue.ValReal (node) => RETURN RealProp.NewConst (FLOAT (node.real));
    | ObValue.ValInt  (node) => RETURN RealProp.NewConst (FLOAT (node.int));
    | ObValue.ValObj =>
      WITH raw = Obliq.ObjectSelect (args[idx], "raw") DO
        TYPECASE raw OF
        | Val (node) =>
          RETURN node.po;
        ELSE
          ObValue.BadArgType (idx, pkgname, package.name, opCode.name, loc);
          RETURN NIL;      (* ... only to suppress compiler warning *)
        END;
      END;
    ELSE
      ObValue.BadArgType (idx, pkgname, package.name, opCode.name, loc);
      RETURN NIL;   (* ... only to suppress compiler warning *)
    END;
  END GetOverloadedVal;
*************************************************************************** Wrapper for RealProp.Beh ***************************************************************************

TYPE
  Beh = ObProp.Beh BRANDED "ObRealProp.Beh" OBJECT END;

PROCEDURE GetBeh (args    : ObValue.ArgArray;
                  idx     : INTEGER;
                  package : ObLib.T;
                  opCode  : ObLib.OpCode;
                  loc     : SynLocation.T) : RealProp.Beh
    RAISES {ObValue.Error, ObValue.Exception} =
  BEGIN
    WITH raw = Obliq.ObjectSelect (args[idx], "raw") DO
      TYPECASE raw OF
      | Beh (node) =>
        RETURN node.po;
      ELSE
        ObValue.BadArgType (idx, pkgname, package.name, opCode.name, loc);
        RETURN NIL;      (* ... only to suppress compiler warning *)
      END;
    END;
  END GetBeh;
*************************************************************************** Wrapper for RealProp.ConstBeh ***************************************************************************

TYPE
  ConstBeh = Beh BRANDED "ObRealProp.ConstBeh" OBJECT END;

PROCEDURE AddConstBehObj (beh : RealProp.ConstBeh) =
  <* FATAL ObValue.Error, ObValue.Exception *>
  BEGIN
    WITH obj = Obliq.ObjectClone (Obliq.Vals {ConstBehProto}),
         raw = NEW (ConstBeh, what := "<a RealProp.ConstBeh>", po := beh) DO
      Obliq.ObjectUpdate (obj, "raw", raw);
      beh.proxy := NEW (ProxiedObj.Proxy, obj := obj);
    END;
  END AddConstBehObj;

PROCEDURE GetConstBeh (args    : ObValue.ArgArray;
                       idx     : INTEGER;
                       package : ObLib.T;
                       opCode  : ObLib.OpCode;
                       loc     : SynLocation.T) : RealProp.ConstBeh
    RAISES {ObValue.Error, ObValue.Exception} =
  BEGIN
    WITH raw = Obliq.ObjectSelect (args[idx], "raw") DO
      TYPECASE raw OF
      | ConstBeh (node) =>
        RETURN node.po;
      ELSE
        ObValue.BadArgType (idx, pkgname, package.name, opCode.name, loc);
        RETURN NIL;      (* ... only to suppress compiler warning *)
      END;
    END;
  END GetConstBeh;
*************************************************************************** Wrapper for RealProp.SyncBeh ***************************************************************************

TYPE
  SyncBeh = Beh BRANDED "ObRealProp.SyncBeh" OBJECT END;

PROCEDURE AddSyncBehObj (beh : RealProp.SyncBeh) =
  <* FATAL ObValue.Error, ObValue.Exception *>
  BEGIN
    WITH obj = Obliq.ObjectClone (Obliq.Vals {SyncBehProto}),
         raw = NEW (SyncBeh, what := "<a RealProp.SyncBeh>", po := beh) DO
      Obliq.ObjectUpdate (obj, "raw", raw);
      beh.proxy := NEW (ProxiedObj.Proxy, obj := obj);
    END;
  END AddSyncBehObj;

PROCEDURE GetSyncBeh (args    : ObValue.ArgArray;
                       idx     : INTEGER;
                       package : ObLib.T;
                       opCode  : ObLib.OpCode;
                       loc     : SynLocation.T) : RealProp.SyncBeh
    RAISES {ObValue.Error, ObValue.Exception} =
  BEGIN
    WITH raw = Obliq.ObjectSelect (args[idx], "raw") DO
      TYPECASE raw OF
      | SyncBeh (node) =>
        RETURN node.po;
      ELSE
        ObValue.BadArgType (idx, pkgname, package.name, opCode.name, loc);
        RETURN NIL;      (* ... only to suppress compiler warning *)
      END;
    END;
  END GetSyncBeh;
*************************************************************************** Wrapper for RealProp.AsyncBeh ***************************************************************************

TYPE
  AsyncBeh = Beh BRANDED "ObRealProp.AsyncBeh" OBJECT END;

PROCEDURE AddAsyncBehObj (beh : RealProp.AsyncBeh) =
  <* FATAL ObValue.Error, ObValue.Exception *>
  BEGIN
    WITH obj = Obliq.ObjectClone (Obliq.Vals {AsyncBehProto}),
         raw = NEW (AsyncBeh, what := "<a RealProp.AsyncBeh>", po := beh) DO
      Obliq.ObjectUpdate (obj, "raw", raw);
      beh.proxy := NEW (AsyncBehProxy, obj := obj);
    END;
  END AddAsyncBehObj;

TYPE
  AsyncBehProxy = RealPropProxy.AsyncBehProxy BRANDED OBJECT
  OVERRIDES
    compute := AsyncBehCompute;
  END;

PROCEDURE AsyncBehCompute (proxy : AsyncBehProxy; time : LONGREAL) : REAL
    RAISES {Prop.BadMethod} =
  BEGIN
    TRY
      WITH args = Obliq.Vals {Obliq.NewReal (time)},
           obj  = NARROW (proxy.obj, Obliq.Val),
           res  = Obliq.ObjectInvoke (obj, "compute", args) DO
        RETURN ObReal.ObliqToM3 (res);
      END;
    EXCEPT
    | ObValue.Error (packet) =>
      RAISE Prop.BadMethod (ObAux.ErrorToText (packet));
    | ObValue.Exception (packet) =>
      RAISE Prop.BadMethod (ObAux.ExceptionToText (packet));
    END;
  END AsyncBehCompute;
*************************************************************************** Wrapper for RealProp.DepBeh ***************************************************************************

TYPE
  DepBeh = Beh BRANDED "ObRealProp.DepBeh" OBJECT END;

PROCEDURE AddDepBehObj (beh : RealProp.DepBeh) =
  <* FATAL ObValue.Error, ObValue.Exception *>
  BEGIN
    WITH obj = Obliq.ObjectClone (Obliq.Vals {DepBehProto}),
         raw = NEW (DepBeh, what := "<a RealProp.DepBeh>", po := beh) DO
      Obliq.ObjectUpdate (obj, "raw", raw);
      beh.proxy := NEW (DepBehProxy, obj := obj);
    END;
  END AddDepBehObj;

TYPE
  DepBehProxy = RealPropProxy.DepBehProxy BRANDED OBJECT
  OVERRIDES
    compute := DepBehCompute;
  END;

PROCEDURE DepBehCompute (proxy : DepBehProxy; time : LONGREAL) : REAL
    RAISES {Prop.BadMethod} =
  BEGIN
    TRY
      WITH args = Obliq.Vals {Obliq.NewReal (time)},
           obj  = NARROW (proxy.obj, Obliq.Val),
           res  = Obliq.ObjectInvoke (obj, "compute", args) DO
        RETURN FLOAT (ObReal.ObliqToM3 (res));
      END;
    EXCEPT
    | ObValue.Error (packet) =>
      RAISE Prop.BadMethod (ObAux.ErrorToText (packet));
    | ObValue.Exception (packet) =>
      RAISE Prop.BadMethod (ObAux.ExceptionToText (packet));
    END;
  END DepBehCompute;
*************************************************************************** Wrapper for RealProp.Request ***************************************************************************

TYPE
  Request = ObProp.Request BRANDED "ObRealProp.Request" OBJECT END;

PROCEDURE AddRequestObj (req : RealProp.Request) =
  <* FATAL ObValue.Error, ObValue.Exception *>
  BEGIN
    WITH obj = Obliq.ObjectClone (Obliq.Vals {RequestProto}),
         raw = NEW (Request, what := "<a RealProp.Request>", po := req) DO
      Obliq.ObjectUpdate (obj, "raw", raw);
      req.proxy := NEW (RequestProxy, obj := obj);
    END;
  END AddRequestObj;

PROCEDURE GetRequest (args    : ObValue.ArgArray;
                      idx     : INTEGER;
                      package : ObLib.T;
                      opCode  : ObLib.OpCode;
                      loc     : SynLocation.T) : RealProp.Request
    RAISES {ObValue.Error, ObValue.Exception} =
  BEGIN
    WITH raw = Obliq.ObjectSelect (args[idx], "raw") DO
      TYPECASE raw OF
      | Request (node) =>
        RETURN node.po;
      ELSE
        ObValue.BadArgType (idx, pkgname, package.name, opCode.name, loc);
        RETURN NIL;      (* ... only to suppress compiler warning *)
      END;
    END;
  END GetRequest;

TYPE
  RequestProxy = RealPropProxy.RequestProxy BRANDED OBJECT
  OVERRIDES
    value := RequestValue;
  END;

PROCEDURE RequestValue (proxy    : RequestProxy;
                        startval : REAL;
                        reltime  : REAL) : REAL
    RAISES {Prop.BadMethod} =
  BEGIN
    TRY
      WITH args = Obliq.Vals {ObReal.M3ToObliq (startval),
                              ObReal.M3ToObliq (reltime)},
           obj  = NARROW (proxy.obj, Obliq.Val),
           res  = Obliq.ObjectInvoke (obj, "value", args) DO
        RETURN FLOAT (ObReal.ObliqToM3 (res));
      END;
    EXCEPT
    | ObValue.Error (packet) =>
      RAISE Prop.BadMethod (ObAux.ErrorToText (packet));
    | ObValue.Exception (packet) =>
      RAISE Prop.BadMethod (ObAux.ExceptionToText (packet));
    END;
  END RequestValue;
*************************************************************************** Setup procedures ***************************************************************************

PROCEDURE SetupPackage () =

  PROCEDURE NewOpCode (name: TEXT; arity: INTEGER; code: Code) : OpCode =
    BEGIN
      RETURN NEW (OpCode, name := name, arity := arity, code := code);
    END NewOpCode;

  TYPE
    OpCodes = ARRAY OF ObLib.OpCode;
  VAR
    opCodes := NEW (REF OpCodes, NUMBER (Code));
  BEGIN
    opCodes^ :=
        OpCodes {
            NewOpCode ("NameBind",           2, Code.NameBind),
            NewOpCode ("ValGetBeh",          1, Code.ValGetBeh),
            NewOpCode ("ValSetBeh",          2, Code.ValSetBeh),
            NewOpCode ("ValGet",             1, Code.ValGet),
            NewOpCode ("ValValue",           2, Code.ValValue),
            NewOpCode ("NewConst",           1, Code.NewConst),
            NewOpCode ("NewSync",            2, Code.NewSync),
            NewOpCode ("NewAsync",           1, Code.NewAsync),
            NewOpCode ("NewDep",             1, Code.NewDep),
            NewOpCode ("ConstBehSet",        2, Code.ConstBehSet),
            NewOpCode ("NewConstBeh",        1, Code.NewConstBeh),
            NewOpCode ("SyncBehAddRequest",  2, Code.SyncBehAddRequest),
            NewOpCode ("SyncBehLinChangeTo", 4, Code.SyncBehLinChangeTo),
            NewOpCode ("SyncBehLinChangeBy", 4, Code.SyncBehLinChangeBy),
            NewOpCode ("NewSyncBeh",         2, Code.NewSyncBeh),
            NewOpCode ("NewAsyncBeh",        1, Code.NewAsyncBeh),
            NewOpCode ("NewDepBeh",          1, Code.NewDepBeh),
            NewOpCode ("NewRequest",         3, Code.NewRequest)
        };

    ObLib.Register (NEW (Package, name := pkgname, opCodes := opCodes));
    ObLib.RegisterHelp (pkgname, Help);
  END SetupPackage;

VAR
  NameProto     : ObValue.Val;
  ValProto      : ObValue.Val;
  ConstBehProto : ObValue.Val;
  SyncBehProto  : ObValue.Val;
  AsyncBehProto : ObValue.Val;
  DepBehProto   : ObValue.Val;
  RequestProto  : ObValue.Val;

PROCEDURE SetupModule (loader : ObProtoLoader.T) =
  BEGIN
    (*** retrieve the prototypes ***)
    loader.load ("RealProp.obl");
    NameProto     := loader.get ("RealProp_NameProto");
    ValProto      := loader.get ("RealProp_ValProto");
    ConstBehProto := loader.get ("RealProp_ConstBehProto");
    SyncBehProto  := loader.get ("RealProp_SyncBehProto");
    AsyncBehProto := loader.get ("RealProp_AsyncBehProto");
    DepBehProto   := loader.get ("RealProp_DepBehProto");
    RequestProto  := loader.get ("RealProp_RequestProto");

    (*** Register the proxy makers ***)
    RealPropProxy.NamePM     := AddNameObj;
    RealPropProxy.ValPM      := AddValObj;
    RealPropProxy.ConstBehPM := AddConstBehObj;
    RealPropProxy.SyncBehPM  := AddSyncBehObj;
    RealPropProxy.AsyncBehPM := AddAsyncBehObj;
    RealPropProxy.DepBehPM   := AddDepBehObj;
    RealPropProxy.RequestPM  := AddRequestObj;
  END SetupModule;
*************************************************************************** Execution machinery ***************************************************************************

TYPE
  Code = {NameBind,
          ValGetBeh, ValSetBeh, ValGet, ValValue,
             NewConst, NewSync, NewAsync, NewDep,
          ConstBehSet, NewConstBeh,
          SyncBehAddRequest, SyncBehLinChangeTo, SyncBehLinChangeBy,
             NewSyncBeh,
          NewAsyncBeh,
          NewDepBeh,
          NewRequest};

  OpCode = ObLib.OpCode BRANDED OBJECT
    code: Code;
  END;

  Package = ObLib.T BRANDED OBJECT
  OVERRIDES
    Eval := DoEval;
  END;

CONST
  pkgname = "RealProp";

PROCEDURE DoEval (self         : Package;
                  opCode       : ObLib.OpCode;
     <* UNUSED *> arity        : ObLib.OpArity;
                  READONLY args: ObValue.ArgArray;
     <* UNUSED *> temp         : BOOLEAN;
                  loc          : SynLocation.T) : ObValue.Val
    RAISES {ObValue.Error, ObValue.Exception} =
  BEGIN
    CASE NARROW (opCode, OpCode).code OF
    | Code.NameBind =>
      WITH pn   = GetName (args, 1, self, opCode, loc),
           pv   = GetVal  (args, 2, self, opCode, loc),
           prop = pn.bind (pv) DO
        RETURN prop.proxy.obj;
      END;
    | Code.ValGetBeh =>
      WITH pv = GetVal (args, 1, self, opCode, loc) DO
        RETURN pv.beh.proxy.obj;
      END;
    | Code.ValSetBeh =>
      WITH pv  = GetVal (args, 1, self, opCode, loc),
           beh = GetBeh (args, 2, self, opCode, loc) DO
        pv.beh := beh;
        RETURN ObValue.valOk;
      END;
    | Code.ValGet =>
      WITH pv = GetVal (args, 1, self, opCode, loc) DO
        TRY
          RETURN ObReal.M3ToObliq (pv.get ());
        EXCEPT
        | Prop.BadMethod =>
          ObValue.RaiseException (ObProp.BadMethod, opCode.name, loc);
          RETURN ObValue.valOk;   (* ... only to suppress compiler warning *)
        END;
      END;
    | Code.ValValue =>
      WITH pv   = GetVal (args, 1, self, opCode, loc),
           time = ObLongReal.GetArg (args, 2, self, opCode, loc) DO
        TRY
          RETURN ObReal.M3ToObliq (pv.value (time));
        EXCEPT
        | Prop.BadMethod =>
          ObValue.RaiseException (ObProp.BadMethod, opCode.name, loc);
          RETURN ObValue.valOk;   (* ... only to suppress compiler warning *)
        END;
      END;
    | Code.NewConst =>
      (*** AddValObj creates the actual Obliq object ***)
      WITH r   = ObReal.GetArg (args, 1, self, opCode, loc),
           val = RealProp.NewConst (r) DO
        RETURN val.proxy.obj;
      END;
    | Code.NewSync =>
      WITH ah  = ObAnimHandle.GetT (args, 1, self, opCode, loc),
           r   = ObReal.GetArg (args, 2, self, opCode, loc),
           val = RealProp.NewSync (ah, r) DO
        RETURN val.proxy.obj;
      END;
    | Code.NewAsync =>
      WITH beh  = NEW (RealProp.AsyncBeh).init (),
           obj  = NARROW (beh.proxy.obj, Obliq.Val) DO
        Obliq.ObjectUpdate (obj, "compute", args[1]);
        WITH val = RealProp.NewAsync (beh) DO
          RETURN val.proxy.obj;
        END;
      END;
    | Code.NewDep =>
      WITH beh = NEW (RealProp.DepBeh).init (),
           obj = NARROW (beh.proxy.obj, Obliq.Val) DO
        Obliq.ObjectUpdate (obj, "compute", args[1]);
        WITH val = RealProp.NewDep (beh) DO
          RETURN val.proxy.obj;
        END;
      END;
    | Code.ConstBehSet =>
      WITH beh = GetConstBeh (args, 1, self, opCode, loc),
           r   = ObReal.GetArg (args, 2, self, opCode, loc) DO
        beh.set (r);
        RETURN ObValue.valOk;
      END;
    | Code.NewConstBeh =>
      WITH r   = ObReal.GetArg (args, 1, self, opCode, loc),
           beh = NEW (RealProp.ConstBeh).init (r) DO
        RETURN beh.proxy.obj;
      END;
    | Code.SyncBehAddRequest =>
      WITH beh = GetSyncBeh (args, 1, self, opCode, loc),
           req = GetRequest (args, 2, self, opCode, loc) DO
        TRY
          beh.addRequest (req);
        EXCEPT
        | Prop.BadInterval =>
          ObValue.RaiseException (ObProp.BadInterval, opCode.name, loc);
        END;
        RETURN ObValue.valOk;
      END;
    | Code.SyncBehLinChangeTo =>
      WITH beh   = GetSyncBeh (args, 1, self, opCode, loc),
           r     = ObReal.GetArg (args, 2, self, opCode, loc),
           start = ObReal.GetArg (args, 3, self, opCode, loc),
           dur   = ObReal.GetArg (args, 4, self, opCode, loc) DO
        TRY
          beh.linChangeTo (r, start, dur);
        EXCEPT
          Prop.BadInterval =>
          ObValue.RaiseException (ObProp.BadInterval, opCode.name, loc);
        END;
        RETURN ObValue.valOk;
      END;
    | Code.SyncBehLinChangeBy =>
      WITH beh   = GetSyncBeh (args, 1, self, opCode, loc),
           r     = ObReal.GetArg (args, 2, self, opCode, loc),
           start = ObReal.GetArg (args, 3, self, opCode, loc),
           dur   = ObReal.GetArg (args, 4, self, opCode, loc) DO
        TRY
          beh.linChangeBy (r, start, dur);
        EXCEPT
          Prop.BadInterval =>
          ObValue.RaiseException (ObProp.BadInterval, opCode.name, loc);
        END;
        RETURN ObValue.valOk;
      END;
    | Code.NewSyncBeh =>
      WITH ah  = ObAnimHandle.GetT (args, 1, self, opCode, loc),
           r   = ObReal.GetArg (args, 2, self, opCode, loc),
           beh = NEW (RealProp.SyncBeh).init (ah, r) DO
        RETURN beh.proxy.obj;
      END;
    | Code.NewAsyncBeh =>
      WITH beh = NEW (RealProp.AsyncBeh).init (),
           obj = NARROW (beh.proxy.obj, Obliq.Val) DO
        Obliq.ObjectUpdate (obj, "compute", args[1]);
        RETURN obj;
      END;
    | Code.NewDepBeh =>
      WITH beh = NEW (RealProp.DepBeh).init (),
           obj = NARROW (beh.proxy.obj, Obliq.Val) DO
        Obliq.ObjectUpdate (obj, "compute", args[1]);
        RETURN obj;
      END;
    | Code.NewRequest =>
      WITH start = ObReal.GetArg (args, 1, self, opCode, loc),
           dur   = ObReal.GetArg (args, 2, self, opCode, loc),
           req   = NEW (RealProp.Request).init (start, dur),
           obj   = NARROW (req.proxy.obj, Obliq.Val) DO
        Obliq.ObjectUpdate (obj, "value", args[3]);
        RETURN obj;
      END;
    END;
  END DoEval;
*************************************************************************** Help ***************************************************************************

PROCEDURE Help (self : ObCommand.T; arg : TEXT; <* UNUSED *> data : REFANY) =
  BEGIN
    ObAux.Help (self, arg, pkgname);
  END Help;

BEGIN
END ObRealProp.

interface ObLongReal is in:


interface ObReal is in: