Celestin Apprentice 2/Apprentice-Release2.iso/Tools/Languages/Open Prolog 1.0.2/External Predicates…/Sources/prlxLibraries.p

Text File | 1993-11-30 | 23.6 KB | 823 lines | [TEXT/MPS ]

{$D+} { MacsBug symbols on }
{$R-} { No range checking }

UNIT prlxLibraries;

  INTERFACE

    USES memtypes, quickdraw, osintf, toolintf,traps,StandardFile,TextUtils, prlxdefinitions;

    TYPE

      oeAction = (oeDoNothing, oeCloseFile, oeCloseResFile, oeDeleteFile,
                  oeDisposHandle, oeDisposPtr);
      oeRecHdl = ^oeRecPtr;
      oeRecPtr = ^oeRec;
      oeRec = RECORD
                action: oeAction;
                parameter: longint;
                next: oeRecHdl;
              END;

    PROCEDURE addOE(VAR list: oeRecHdl;
                    action: oeAction;
                    parameter: longint);


    FUNCTION removeOE(VAR list: oeRecHdl;
                      action: oeAction;
                      parameter: longint): osErr;

    FUNCTION doOE(VAR list: oeRecHdl): osErr;


    PROCEDURE initOE(VAR list: oeRecHdl);

    FUNCTION terminateOE(VAR list: oeRecHdl): osErr;

    FUNCTION TrapAvailable(tNumber: integer; tType: TrapType): boolean;

    FUNCTION getStringNumber(id, index: integer): longint;


    FUNCTION walkAList(list: termIndex;
                       VAR head, tail: termIndex;
                       plist: prlxptr): boolean;

    FUNCTION textOfAtomicList(termnumber: termindex;
                              plist: prlxPtr): str255;

    FUNCTION returnString(termNumber: termIndex;
                          st: str255;
                          plist: prlxPtr): boolean;

    PROCEDURE openPrologDialogFilter(VAR i: integer; plist:prlxPtr);

    PROCEDURE writestr(st: str255; plist: prlxPtr);

    PROCEDURE writelnstr(st: str255; plist: prlxPtr);

    PROCEDURE errorstr(st: str255; plist: prlxPtr);

    FUNCTION returnValue(termNumber: termIndex; n: longint;
                         plist: prlxPtr): boolean;

    FUNCTION returnStructure(termNumber: termIndex; st: str255; arity: integer;
                             plist: prlxPtr): boolean;

    FUNCTION returnList(termNumber: termIndex; plist: prlxPtr): boolean;

    FUNCTION returnAtom(termNumber: termIndex; st: str255;
                        plist: prlxPtr): boolean;

    FUNCTION returnUnifiedTerms(a, b: termIndex; plist: prlxPtr): boolean;

    FUNCTION subterm(subtermordinate: integer; termNumber: termIndex;
                     plist: prlxPtr): termIndex;

    FUNCTION newFreeTerm(plist: prlxPtr): termIndex;

    FUNCTION number(termNumber: termIndex; plist: prlxPtr): boolean;

    FUNCTION atom(termNumber: termIndex; plist: prlxPtr): boolean;

    FUNCTION structure(termNumber: termIndex; plist: prlxPtr): boolean;

    FUNCTION list(termNumber: termIndex; plist: prlxPtr): boolean;

    FUNCTION variable(termNumber: termIndex; plist: prlxPtr): boolean;

    FUNCTION value(termNumber: termIndex; plist: prlxPtr): longint;

    FUNCTION arity(termNumber: termIndex; plist: prlxPtr): integer;

    FUNCTION text(termNumber: termIndex; plist: prlxPtr): str255;

    FUNCTION drawAlert(ALRTid: integer; st: str255; plist: prlxPtr): longint;

    FUNCTION centreDialog(DLOGid: integer; plist: prlxPtr): longint;

    PROCEDURE centreSfGetTEXTFile(vertical: integer; str: str255;
                                  VAR reply: sfReply);

    PROCEDURE centreSfPutFile(vertical: integer; str: str255; origName: str255;
                              dlgHook: procPtr; VAR reply: sfReply);

    FUNCTION getFileName(VAR FileName: str255;
                         VAR FileVolume: longint): boolean;

    FUNCTION predicateNameAndArity(VAR name: str255; VAR arity: integer;
                                   plist: prlxPtr): boolean;

    PROCEDURE signalError(error: integer; argumentIndex: integer;
                          hostErrorCode: longint; errorMessage: str255;
                          plist: prlxPtr);

  IMPLEMENTATION

    PROCEDURE signalError(error: integer; argumentIndex: integer;
                          hostErrorCode: longint; errorMessage: str255;
                          plist: prlxPtr);

    {if you want to throw an error from an external predicate, use this}
    {error kind is an index to an ISO error type - see prlxDefinitions.p}
    {hostErrorCode is where you can put a mac error code}
    {give an argument index of -1 if you don't want it to try to output the goal's name}

      VAR
        i: integer;
        t, r, q: termIndex;
        ignoreBoolean: boolean;
        thePredicateName: str255;
        thePredicateArity: integer;

      BEGIN

        WITH plist^ DO
          BEGIN
          outcome := error; {outcome is normally 'notAnErrorCode' - this puts a
                             real error code there}
          data[1] := newFreeTerm(plist);
          END;
        ignoreBoolean := predicateNameAndArity(thePredicateName,
                                               thePredicateArity, plist);

        q := plist^.data[1];

        IF argumentIndex <> - 1 {-1 is flag to not even try to output the goal's name}
          THEN
            BEGIN
            ignoreBoolean := returnList(q, plist); {return a list of error
                                                    information}
            r := subterm(1, q, plist);
            ignoreBoolean := returnStructure(r, 'goal', 1, plist); {first, the
              goal - functor & arguments}
            r := subterm(1, r, plist);
            ignoreBoolean := returnStructure(r, thePredicateName,
                                             thePredicateArity, plist);
            FOR i := 1 TO thePredicateArity DO
              ignoreBoolean := returnUnifiedTerms(subterm(i, r, plist), i,
                                                  plist); {the goal's
                                                            arguments}
            q := subterm(2, q, plist);
            END;

        IF argumentIndex > 0 {if the argument index is 0 or -1, no argument
                              index info returned}
          THEN
            BEGIN
            ignoreBoolean := returnList(q, plist);
            r := subterm(1, q, plist);
            ignoreBoolean := returnStructure(r, 'argument_index', 1, plist);
            r := subterm(1, r, plist);
            ignoreBoolean := returnValue(r, argumentIndex, plist);
            q := subterm(2, q, plist);
            END;

        IF hostErrorCode <> 0 {if the mac error code = 0, no host error info
                               returned}
          THEN
            BEGIN
            ignoreBoolean := returnList(q, plist);
            r := subterm(1, q, plist);
            ignoreBoolean := returnStructure(r, 'host_error_code', 1, plist);
            r := subterm(1, r, plist);
            ignoreBoolean := returnValue(r, hostErrorCode, plist);
            q := subterm(2, q, plist);
            END;

        IF errorMessage <> '' {only return an error message term if it's
                               non-blank}
          THEN
            BEGIN
            ignoreBoolean := returnList(q, plist);
            r := subterm(1, q, plist);
            ignoreBoolean := returnStructure(r, 'error_message', 1, plist);
            r := subterm(1, r, plist);
            ignoreBoolean := returnAtom(r, errorMessage, plist);
            q := subterm(2, q, plist);
            END;

        ignoreBoolean := returnAtom(q, '[]', plist); {terminate the list}
      END;

    PROCEDURE addOE(VAR list: oeRecHdl;
                    action: oeAction;
                    parameter: longint);

      VAR
        temp: oeRecHdl;

      BEGIN
        temp := oeRecHdl(newHandleClear(sizeOf(oeRec)));
        temp^^.next := list;
        list := temp;
        list^^.action := action;
        list^^.parameter := parameter;
      END;

    FUNCTION existsOE(VAR list: oeRecHdl;
                      action: oeAction;
                      VAR parameter: longint): boolean;

      VAR
        temp: oeRecHdl;
        found: boolean;

      BEGIN
        temp := list;
        found := false;
        REPEAT
          IF temp <> NIL THEN
            BEGIN
            IF temp^^.action = action THEN
              found := true
            ELSE
              temp := temp^^.next;
            END;
        UNTIL (temp = NIL) OR found;
        IF found THEN parameter := temp^^.parameter;
        existsOE := found;
      END;

    FUNCTION removeOE(VAR list: oeRecHdl;
                      action: oeAction;
                      parameter: longint): osErr;

      VAR
        temp: oeRecHdl;
        found: boolean;

      BEGIN
        temp := list;
        REPEAT
          IF temp <> NIL THEN
            BEGIN
            found := (temp^^.action = action) AND (temp^^.parameter =
                     parameter);
            IF NOT found THEN temp := temp^^.next;
            END;
        UNTIL (temp = NIL) OR found;
        IF found THEN
          BEGIN
          removeOE := noErr;
          temp^^.action := oeDoNothing;
          END
        ELSE
          removeOE := paramErr;
      END;

    FUNCTION doOE(VAR list: oeRecHdl): osErr;

      TYPE
        fssSpecPtr = ^fsSpec;

      VAR
        temp: oeRecHdl;
        thePort: grafPtr;
        errorCode: osErr;

      BEGIN
        errorCode := noErr;
        WHILE (list <> NIL) AND (errorCode = noErr) DO
          WITH list^^ DO
            BEGIN
            hLock(handle(list));
            CASE action OF
              oeDoNothing: ;
              oeCloseFile: errorCode := fsClose(parameter);
              oeCloseResFile:
                BEGIN
                closeResFile(parameter);
                errorCode := resError;
                END;
              oeDeleteFile: errorCode := fSpDelete(fssSpecPtr(parameter)^);
              oeDisposHandle:
                BEGIN
                disposHandle(handle(parameter));
                errorCode := memError;
                END;
              oeDisposPtr:
                BEGIN
                disposPtr(ptr(parameter));
                errorCode := memError;
                END;
            END;
            IF errorCode = noErr THEN
              BEGIN
              temp := list^^.next;
              disposHandle(handle(list));
              list := temp;
              END;
            END;
      END;

    PROCEDURE initOE(VAR list: oeRecHdl);

      BEGIN
        list := NIL;
      END;

    FUNCTION terminateOE(VAR list: oeRecHdl): osErr;

      VAR
        temp: oeRecHdl;
        result: osErr;

      BEGIN
        result := 0;
        WHILE list <> NIL DO
          BEGIN
          IF list^^.action <> oeDoNothing THEN result := paramErr;
          temp := list;
          list := list^^.next;
          disposHandle(handle(temp));
          END;
        terminateOE := result;
      END;

      PROCEDURE openPrologDialogFilter(VAR i: integer; plist:prlxPtr);

        VAR
          l: longint;

        BEGIN
          WITH plist^ DO
            BEGIN
            callbackrequest := doMyModalDialog;
            callback(entrypoint);
            l := callbackdata[1];
            i := l;
            END;
        END;

    FUNCTION TrapAvailable(tNumber: integer; tType: TrapType): boolean;

{Check to see if a given trap is implemented.
 The recommended approach to see if a trap is implemented is to see if
 the address of the trap routine is the same as the address of the
 Unimplemented trap.}

      VAR
        gMac: sysEnvRec;
        errCode: osErr;

      BEGIN
        errCode := noErr;
        IF (tType = ToolTrap)
          THEN
            BEGIN
            errCode := sysEnvirons(1, gMac);
            IF (errCode = noErr) & (gMac.machineType > envMachUnknown) &
               (gMac.machineType < envMacII)
              THEN
                BEGIN {it's a 512KE, Plus, or SE}
                tNumber := BAND(tNumber, $03FF);
                IF tNumber > $01FF
                  THEN {which means the tool traps}
                    tNumber := _Unimplemented; {only go to $01FF}
                END;
            END;
        TrapAvailable := (NGetTrapAddress(tNumber, tType) <>
                         GetTrapAddress(_Unimplemented)) AND (errCode = noErr);
      END; {TrapAvailable}

    FUNCTION getStringNumber(id, index: integer): longint;

      VAR
        s: Str255;
        n: longint;
        i: integer;

      BEGIN
        getIndString(s, id, index);
        i := 1;
        n := 0;
        IF length(s) <> 0 THEN
          WHILE (i <= length(s)) AND (s[i] IN ['0'..'9']) DO
            BEGIN
            n := n * 10 + ord(s[i]) - ord('0');
            i := i + 1;
            END;
        getStringNumber := n;
      END;

    FUNCTION walkAList(list: termIndex;
                       VAR head, tail: termIndex;
                       plist: prlxptr): boolean;

      BEGIN
        IF (text(list, plist) = '.') AND (arity(list, plist) = 2) THEN
          BEGIN
          walkAList := true;
          head := subTerm(1, list, plist);
          tail := subTerm(2, list, plist);
          END
        ELSE
          walkAList := false;
      END;

    FUNCTION textOfAtomicList(termnumber: termindex;
                              plist: prlxPtr): str255;

      VAR
        st: str255;
        i: integer;

      BEGIN
        IF (text(termNumber, plist) <> '.') OR (arity(termNumber, plist) <>
           2) THEN
          textOfAtomicList := text(termNumber, plist)
        ELSE
          BEGIN
          st := '';
          WHILE (text(termNumber, plist) = '.') AND (arity(termNumber, plist) =
                2) DO
            BEGIN
            st := concat(st, char(value(subterm(1, termNumber, plist), plist)));
            termNumber := subterm(2, termNumber, plist);
            END;
          textOfAtomicList := st;
          END;
      END;

    FUNCTION returnString(termNumber: termIndex;
                          st: str255;
                          plist: prlxPtr): boolean;

      VAR
        continue: boolean;
        i: integer;
        runningTerm: termIndex;

      BEGIN
        runningTerm := termNumber;
        continue := true;
        IF st <> '' THEN
          FOR i := 1 TO length(st) DO
            BEGIN
            IF continue THEN
              continue := returnStructure(runningTerm, '.', 2, plist);
            IF continue THEN
              continue := returnValue(subterm(1, runningTerm, plist),
                                      ord(st[i]), plist);
            IF continue THEN runningTerm := subterm(2, runningTerm, plist);
            END;
        IF continue THEN continue := returnAtom(runningTerm, '[]', plist);
        returnString := continue;
      END;

    PROCEDURE writestr(st: str255; plist: prlxPtr);

      BEGIN
        WITH plist^ DO
          BEGIN
          callbackrequest := writestring;
          s := st;
          callback(entrypoint);
          END;
      END;

    PROCEDURE writelnstr(st: str255; plist: prlxPtr);

      BEGIN
        WITH plist^ DO
          BEGIN
          callbackrequest := writelnstring;
          s := st;
          callback(entrypoint);
          END;
      END;

    PROCEDURE errorstr(st: str255; plist: prlxPtr);

      BEGIN
        WITH plist^ DO
          BEGIN
          callbackrequest := writeerror;
          s := st;
          callback(entrypoint);
          END;
      END;

    FUNCTION predicateNameAndArity(VAR name: str255; VAR arity: integer;
                                   plist: prlxPtr): boolean;

      BEGIN
        WITH plist^ DO
          BEGIN
          callbackrequest := getPredicateNameAndArity;
          callback(entrypoint);
          predicateNameAndArity := callbackData[3] = messageOK;
          name := s;
          arity := callbackData[1];
          END;
      END;

    FUNCTION returnUnifiedTerms(a, b: termIndex; plist: prlxPtr): boolean;

      BEGIN
        WITH plist^ DO
          BEGIN
          callbackrequest := unifyTerms;
          callbackData[1] := a;
          callbackData[2] := b;
          callback(entrypoint);
          returnUnifiedTerms := callbackData[3] = messageOK;
          END;
      END;

    FUNCTION returnValue(termNumber: termIndex; n: longint;
                         plist: prlxPtr): boolean;

      BEGIN
        WITH plist^ DO
          BEGIN
          callbackrequest := unifyToInteger;
          callbackData[1] := termNumber;
          callbackData[2] := n;
          callback(entrypoint);
          returnValue := callbackData[3] = messageOK;
          END;
      END;

    FUNCTION returnList(termNumber: termIndex; plist: prlxPtr): boolean;

      BEGIN
        WITH plist^ DO
          BEGIN
          callbackrequest := unifyToFunctor;
          callbackData[1] := termNumber;
          callbackData[3] := 2;
          s := '.';
          callback(entrypoint);
          returnList := callbackData[3] = messageOK;
          END;
      END;

    FUNCTION returnStructure(termNumber: termIndex; st: str255; arity: integer;
                             plist: prlxPtr): boolean;

      BEGIN
        WITH plist^ DO
          BEGIN
          callbackrequest := unifyToFunctor;
          callbackData[1] := termNumber;
          callbackData[3] := arity;
          s := st;
          callback(entrypoint);
          returnStructure := callbackData[3] = messageOK;
          END;
      END;

    FUNCTION returnAtom(termNumber: termIndex; st: str255;
                        plist: prlxPtr): boolean;

      BEGIN
        returnAtom := returnStructure(termNumber, st, 0, plist);
      END;

    FUNCTION subterm(subtermordinate: integer; termNumber: termIndex;
                     plist: prlxPtr): termIndex;

      BEGIN
        WITH plist^ DO
          BEGIN
          callbackrequest := getsubterm;
          callbackData[1] := termNumber;
          callbackData[2] := subtermordinate;
          callback(entrypoint);
          subterm := callbackData[3];
          END;
      END;

    FUNCTION newFreeTerm(plist: prlxPtr): termIndex;

      BEGIN
        WITH plist^ DO
          BEGIN
          callbackrequest := getFreeTerm;
          callback(entrypoint);
          newFreeTerm := callbackData[1];
          END;
      END;

    FUNCTION number(termNumber: termIndex; plist: prlxPtr): boolean;

      BEGIN
        WITH plist^ DO
          BEGIN
          callbackrequest := getterminfo;
          callbackData[1] := termNumber;
          callback(entrypoint);
          number := (callbackData[1] = integertag);
          END;
      END;

    FUNCTION atom(termNumber: termIndex; plist: prlxPtr): boolean;

      BEGIN
        WITH plist^ DO
          BEGIN
          callbackrequest := getterminfo;
          callbackData[1] := termNumber;
          callback(entrypoint);
          atom := (callbackData[1] = atomtag);
          END;
      END;

    FUNCTION structure(termNumber: termIndex; plist: prlxPtr): boolean;

      BEGIN
        WITH plist^ DO
          BEGIN
          callbackrequest := getterminfo;
          callbackData[1] := termNumber;
          callback(entrypoint);
          structure := (callbackData[1] = structuretag);
          END;
      END;

    FUNCTION list(termNumber: termIndex; plist: prlxPtr): boolean;

      BEGIN
        WITH plist^ DO
          BEGIN
          callbackrequest := getterminfo;
          callbackData[1] := termNumber;
          callback(entrypoint);
          list := ((callbackData[1] = structuretag) AND (s = '.') AND
                  (callbackData[2] = 2)) OR ((callbackData[1] = atomtag) AND
                  (s = '[]'));
          END;
      END;

    FUNCTION variable(termNumber: termIndex; plist: prlxPtr): boolean;

      BEGIN
        WITH plist^ DO
          BEGIN
          callbackrequest := getterminfo;
          callbackData[1] := termNumber;
          callback(entrypoint);
          variable := (callbackData[1] = variabletag);
          END;
      END;

    FUNCTION value(termNumber: termIndex; plist: prlxPtr): longint;

      BEGIN
        WITH plist^ DO
          BEGIN
          callbackrequest := getterminfo;
          callbackData[1] := termNumber;
          callback(entrypoint);
          IF callbackData[1] = integertag
            THEN value := callbackData[2]
            ELSE errorstr('attempt to get value of a non-integer', plist);
          END;
      END;

    FUNCTION arity(termNumber: termIndex; plist: prlxPtr): integer;

      BEGIN
        WITH plist^ DO
          BEGIN
          callbackrequest := getterminfo;
          callbackData[1] := termNumber;
          callback(entrypoint);
          CASE callbackData[1] OF
            atomtag, integertag, variabletag: arity := 0;
            structuretag: arity := callbackData[2];
            OTHERWISE errorstr('Funny data from getTermInfo in arity', plist);
          END;
          END;
      END;

    FUNCTION text(termNumber: termIndex; plist: prlxPtr): str255;

      VAR
        st: str255;
        i: integer;

      BEGIN
        WITH plist^ DO
          BEGIN
          callbackrequest := getterminfo;
          callbackData[1] := termNumber;
          callback(entrypoint);
          CASE callbackData[1] OF
            atomtag, structuretag: text := s;
            integertag:
              BEGIN
              numtostring(callbackData[2], st);
              text := st;
              END;
            variabletag:
              BEGIN
              numtostring(callbackData[2], st);
              FOR i := 255 DOWNTO 2 DO st[i] := st[i - 1];
              st[1] := '_';
              text := st;
              END;
            OTHERWISE errorstr('Funny data from getTermInfo in text', plist);
          END;
          END;
      END;

    FUNCTION drawAlert(ALRTid: integer; st: str255; plist: prlxPtr): longint;

      BEGIN
        WITH plist^ DO
          BEGIN
          callbackrequest := drawALRT;
          callbackData[1] := ALRTid;
          s := st;
          callback(entrypoint);
          drawAlert := callbackData[2];
          END;
      END;

    FUNCTION centreDialog(DLOGid: integer; plist: prlxPtr): longint;

      VAR
        item: integer;
        myDialog: dialogPtr;

      BEGIN
        WITH plist^ DO
          BEGIN
  (* ###hack        callbackrequest := drawDLOG;
          callbackData[1] := DLOGid;
           callback(entrypoint);
          centreDialog := callbackData[2]; *)

          myDialog := getNewDialog(DLOGid, NIL, windowPtr(1));
          showWindow(myDialog);
          modalDialog(NIL, item);
          disposDialog(myDialog);
          centreDialog := item;
          END;
      END;

    PROCEDURE centreSfGetTEXTFile(vertical: integer; str: str255;
                                  VAR reply: sfReply);

      VAR
        myPoint: point;
        dialogHandle: dialogTHndl;
        myPort: grafPtr;
        screenWidth, dialogWidth: integer;
        myTypeList: sfTypeList;

      BEGIN
        myTypeList[0] := 'TEXT';
        getPort(myPort);
        WITH myPort^.portBits.bounds DO screenWidth := right - left;
        dialogHandle := dialogTHndl(getResource('DLOG', getDlgId));
        WITH dialogHandle^^.boundsRect DO
          BEGIN
          dialogWidth := right - left;
          myPoint.h := (screenWidth - dialogWidth) DIV 2;
          myPoint.v := vertical;
          END;
        sfGetFile(myPoint, str, NIL, 1, myTypeList, NIL, reply);
      END;

    PROCEDURE centreSfPutFile(vertical: integer; str: str255; origName: str255;
                              dlgHook: procPtr; VAR reply: sfReply);

      VAR
        myPoint: point;
        dialogHandle: dialogTHndl;
        myPort: grafPtr;
        screenWidth, dialogWidth: integer;

      BEGIN
        getPort(myPort);
        WITH myPort^.portBits.bounds DO screenWidth := right - left;
        dialogHandle := dialogTHndl(getResource('DLOG', putDlgId));
        WITH dialogHandle^^.boundsRect DO
          BEGIN
          dialogWidth := right - left;
          myPoint.h := (screenWidth - dialogWidth) DIV 2;
          myPoint.v := vertical;
          END;
        sfPutFile(myPoint, str, origName, dlgHook, reply);
      END;

    FUNCTION getFileName(VAR FileName: str255;
                         VAR FileVolume: longint): boolean;

      VAR
        reply: sfReply;

      BEGIN
        centreSfGetTEXTFile(75, '', reply);
        FileName := reply.fName;
        FileVolume := reply.vRefNum;
        getFileName := reply.good;
      END;

END.