/*****************************************************************/ 
/* E L I Z A      V 0.1         03.10.87  BY KIO !               */ 
/* ---------                                                     */ 
/* Dies ist eine PEARL - Version des legendaeren Psychoanalyse-  */ 
/* programms von Joseph Weizenbaum.                              */ 
/*****************************************************************/ 

/*!*/ /*+M*/;/*+T*/;/*-L*/ SC=$2200; 
/*!*/ 
/*!*/ MODULE ELIZA; 
/*!*/ 
/*!*/ SYSTEM; 
/*!*/ 
/*!*/ VI: VI.TOGAME     <-; 
/*!*/ VO: VO.FROMGAME   ->; 

      DT: ED.ELIDAT (NE); 

/*!*/ 
/*!*/ PROBLEM; 
/*!*/ 
/*!*/ SPC VI DATION IN  ALPHIC CONTROL(ALL), 
/*!*/     VO DATION OUT ALPHIC CONTROL(ALL); 
/*!*/ 
/*!*/ DCL INCHAR           FIXED; 
/*!*/ DCL USRNR   FIX; 
/*!*/ DCL NAME    CHAR(16); 
/*!*/ DCL MAXTIME DURATION; 
/*!*/ DCL TAGESNR FIX; 
/*!*/ 

DCL (S1,S2)FIXED(31) INIT(0(31),0(31)); 

SPC DT DATION INOUT ALPHIC CONTROL(ALL); 

SPC RANF ENTRY RETURNS(FLOAT(23))GLOBAL; 

TYPE TXT CHAR(80), 
     SW  STRUCT (/ FLG CHAR, TXT CHAR(11),(A,E) FIXED /); 

DCL TRUE  INV BIT INIT('1'B), 
    FALSE INV BIT INIT('0'B); 

/* ========================================================= */ 

/*!*/ LEN: PROC (T CHAR(80)) RETURNS(FIXED); 
/*!*/   FOR I FROM 80 BY -1 TO 1 REPEAT 
/*!*/     IF T.CHAR(I)/=' ' THEN RETURN(I);FIN; 
/*!*/     END; 
/*!*/   RETURN(0); 
/*!*/   END; 
/*!*/ 
/*!*/ SEND: PROC(T CHAR(80)); 
/*!*/   PUT LEN(T),T TO VO BY F(2),A(77),SKIP; 
/*!*/   GET INCHAR FROM VI BY F(9); 
/*!*/   END; 
/*!*/ 
/*!*/ SENDCR: PROC; 
/*!*/   PUT '-1 'TO VO BY A,SKIP; 
/*!*/   GET INCHAR FROM VI BY F(9); 
/*!*/   END; 
/*!*/ 
/*!*/ SENDCHAR: PROC(C FIXED); 
/*!*/   IF C==13 THEN CALL SENDCR; 
/*!*/            ELSE PUT '01'><TOCHAR(C) TO VO BY A,SKIP; 
/*!*/                 GET INCHAR FROM VI BY F(9); 
/*!*/            FIN; 
/*!*/   END; 
/*!*/ 
/*!*/ SENDEN: PROC(S CHAR(80)); 
/*!*/   CALL SEND(S); 
/*!*/   CALL SENDCR; 
/*!*/   END; 
/*!*/ 
/*!*/ ENDE: PROC; 
/*!*/   CALL SENDCR; 
/*!*/   CALL SENDCR; 
/*!*/   CALL SENDEN('BYE BYE !'); 
/*!*/   CALL SENDCR; 
/*!*/   PUT '-2 ' TO VO BY A,SKIP; 
/*!*/   TERMINATE; 
/*!*/   END; 
/*!*/ 
/*!*/ PARAMETERUEBERNAHME: PROC;     /* NEU: 7.3.88 */ 
/*!*/   DCL Z TXT; 
/*!*/   GET USRNR   FROM VI BY F(5); 
/*!*/   GET NAME    FROM VI BY A(16); 
/*!*/   GET MAXTIME FROM VI BY D(8); 
/*!*/   GET TAGESNR FROM VI BY F(5); 
/*!*/   GET Z       FROM VI BY A;     /* SKIP REST */ 
/*!*/   END; 
/*!*/ 
/*!*/ INPUT: PROC RETURNS(FIXED); 
/*!*/   DCL C FIXED; 
/*!*/   C=INCHAR;INCHAR=0; 
/*!*/   WHILE C==0 REPEAT; 
/*!*/     AFTER 0.05 SEC RESUME; 
/*!*/     PUT '00 ' TO VO BY A,SKIP; 
/*!*/     GET C FROM VI BY F(9); 
/*!*/     END; 
/*!*/   CALL SENDCHAR(C); 
/*!*/   RETURN(C); 
/*!*/   END; 

/* ======================================================== */ 

MIN: PROC((A,B)FIXED)RETURNS(FIXED); 
  IF A<=B THEN RETURN(A);ELSE RETURN(B);FIN; 
  END; 

MAX: PROC((A,B)FIXED)RETURNS(FIXED); 
  IF A>=B THEN RETURN(A);ELSE RETURN(B);FIN; 
  END; 

UPC: PROC (N FIXED) RETURNS(FIXED); 
  IF N<96 THEN RETURN(N);FIN; 
  RETURN(N-32); 
  END; 

DELTXT: PROC(S TXT IDENT, (P,N)FIXED); 
  DCL L FIXED; 
  L=LEN(S);IF L<P THEN RETURN;FIN; 
  FOR I FROM P+N TO L REPEAT;S.CHAR(I-N)=S.CHAR(I);END; 
  FOR I FROM L-N+1 TO L REPEAT;S.CHAR(I)=' ';END; 
  END; 

INSTXT: PROC(S TXT IDENT, T TXT, P FIXED); 
  DCL L FIXED; 
  L=LEN(T); 
  FOR I FROM MIN(LEN(S),80-L) BY -1 TO P REPEAT 
    S.CHAR(I+L)=S.CHAR(I); 
    END; 
  FOR I FROM 1 TO MIN(L,80+1-P) REPEAT 
    S.CHAR(P+I-1)=T.CHAR(I); 
    END; 
  END; 

INSTR: PROC(S TXT IDENT, T TXT,N FIXED)RETURNS(FIXED); 
  DCL L FIXED; 
  L=LEN(T); 
  IF L==0 THEN RETURN(0);FIN; 
  FOR I FROM N TO LEN(S)-L REPEAT 
    FOR J TO L WHILE S.CHAR(I+J)==T.CHAR(J) REPEAT 
      IF J==L THEN RETURN(I+1);FIN; 
      END; 
    END; 
  RETURN(99); 
  END; 

ISBEGINNINGOF: PROC(T CHAR(20),S TXT IDENT) RETURNS(BIT); 
  FOR I FROM LEN(T) BY -1 TO 1 REPEAT; 
    IF T.CHAR(I)/=S.CHAR(I) THEN RETURN(FALSE);FIN; 
    END; 
  RETURN(TRUE); 
  END; 

XCHTXT: PROC(S TXT IDENT, (T,U)TXT); 
  DCL (I,N,M) FIXED; 
  I=0; 
  REPEAT 
    N=INSTR(S,T,I); 
    M=INSTR(S,U,I); 
    IF N>80 AND M>80 THEN RETURN;FIN; 
    IF N<M 
      THEN I=N;CALL DELTXT(S,N,LEN(T));CALL INSTXT(S,U,N); 
      ELSE I=M;CALL DELTXT(S,M,LEN(U));CALL INSTXT(S,M,M); 
      FIN; 
    END; 
  END; 

FIRSTWORD: PROC (S TXT IDENT) RETURNS(TXT); 
  DCL T TXT; 
  T=''; 
  FOR I TO 80 REPEAT; 
    T.CHAR(I)=S.CHAR(I); 
    IF T.CHAR(I)==' ' 
      THEN CALL DELTXT(S,1,I); 
           RETURN(T); 
      FIN; 
    END; 
  END; 

SATZZEICHEN: PROC (S TXT IDENT); 
  DCL Z FIXED; 
  FOR I FROM LEN(S) BY -1 TO 2 REPEAT; 
    Z=TOFIXED(S.CHAR(I)); 
    IF (Z<65 AND Z>57) OR Z<48 
      THEN IF S.CHAR(I+1)/=' ' AND S.CHAR(I-1)/=' ' 
           THEN S.CHAR(I)=' '; 
           ELSE CALL DELTXT(S,I,1); 
           FIN; 
      FIN; 
    END; 
  END; 

XCHPRONOMEN: PROC(S TXT IDENT); 
  CALL XCHTXT(S,'ICH' ,'DU'    ); 
  CALL XCHTXT(S,'DEIN','MEIN'  ); 
  CALL XCHTXT(S,'MIR' ,'DIR'   ); 
  CALL XCHTXT(S,'BIN' ,'BIST'  ); 
  CALL XCHTXT(S,'HABE','HAST'  ); 
  CALL XCHTXT(S,'KANN','KANNST'); 
  CALL XCHTXT(S,'SOLL','SOLLST'); 
  CALL XCHTXT(S,'WILL','WILLST'); 
  END; 

/* SIND 
   BIN 
   WAREN 
   WAR    */ 


/* ======================================================== */ 


DATEIEINLESEN: PROC(W()SW IDENT,AS()TXT IDENT); 
  DCL (WP,AP) FIXED,C CHAR,S TXT; 
  WP=0;AP=0; 
  OPEN DT;CALL REWIND(DT); 
  GET C,S FROM DT BY A(1),A; 
  WHILE ST(DT)==0 REPEAT 
    IF C==' ' 
      THEN AP=AP+1;AS(AP)=S; 
      ELSE FOR I FROM WP BY -1 TO 1 WHILE W(I).A==W(WP).A REPEAT 
             W(I).E=AP; 
             END; 
           WP=WP+1;W(WP).TXT=S;W(WP).A=AP+1;W(WP).FLG=C; 
      FIN; 
    GET C,S FROM DT BY A(1),A; 
    END; 
  CLOSE DT; 
  END; 

/* ======================================================== */ 

INPUTSTR: PROC RETURNS(TXT); 
  DCL S TXT,L FIXED; 
  DCL C FIXED; 
  L=0;S=''; 
  CALL SENDCHAR(62);  /* > */ 
  CALL SENDCHAR(32); 
  REPEAT 
    C=UPC(INPUT); 
    IF C==13 THEN RETURN(S);FIN; 
    IF C==8 
      THEN IF L>0 THEN S.CHAR(L)=' '; 
                       L=L-1; 
                  ELSE CALL SENDCHAR(32); 
                  FIN; 
      ELSE IF L<77 THEN L=L+1;S.CHAR(L)=TOCHAR(C);FIN; 
      FIN; 
    END; 
  END; 

/* ======================================================== */ 

/* STANDARD-ANTWORTEN AUF STICHWORTE */ 

STICHWORTANTWORT: PROC (S TXT IDENT,W()SW IDENT) RETURNS(FIXED); 
  FOR I TO 9999 REPEAT 
    IF W(I).FLG=='-' 
      THEN IF INSTR(S,W(I).TXT,0)<=80 THEN RETURN(I);FIN; 
      ELSE IF ISBEGINNINGOF(W(I).TXT,S) THEN RETURN(I);FIN; 
      FIN; 
    END; 
  CALL ENDE ;  /* CRITICAL ERROR #1 */ 
  END; 

ANTWORTSATZ: PROC(W SW) RETURNS(FIXED); 
  RETURN(W.A+ENTIER(RANF(S1,S2)*(W.E+1-W.A))); 
  END; 

/* ======================================================== */ 

ELIZA: TASK; 

  DCL C CHAR; 

  DCL EINGABE     TXT, 
      ALTEEINGABE TXT, 
      THEMA       FIXED, 
      THEMACOUNT  FIXED, 
      STICHWORT   FIXED, 
      ANTWORT     FIXED, 
      ALTEANTWORT FIXED; 

  DCL STIW(100)SW,           /* STICHWORTE & ANTWORTPOINTER */ 
      ANTW(500)TXT;          /* ANTWORTEN                   */ 

  CALL PARAMETERUEBERNAHME;
  CALL DATEIEINLESEN(STIW,ANTW); 

  ALTEEINGABE=''; 
  THEMA=0; 
  THEMACOUNT=0; 
  ALTEANTWORT=0; 

  CALL SENDCR; 
  CALL SENDEN('ELIZA .... IN .... THE .... KIO-BOX !'); 
  CALL SENDEN('-------------------------------------'); 
  CALL SENDCR; 
  CALL SENDCR; 
  CALL SENDEN('HALLO, HIER IST ELIZA. WAS HAST DU AUF DEM HERZEN?'); 

  REPEAT 

    EINGABE=INPUTSTR; 
    CALL SATZZEICHEN(EINGABE); 

    IF EINGABE=='       ' 
      THEN EINGABE='leer'; 
      ELSE 
        WHILE EINGABE==' ' REPEAT;CALL DELTXT(EINGABE,1,1);END; 
        IF EINGABE=='END' OR EINGABE=='BYE' OR EINGABE=='TSCH' 
          THEN CALL ENDE;FIN; 
        IF EINGABE==ALTEEINGABE 
          THEN EINGABE='selbe'; 
          ELSE IF LEN(EINGABE)<5 
               THEN EINGABE='zukurz'; 
               ELSE ALTEEINGABE=EINGABE; 
               FIN; 
          FIN; 
      FIN; 

    STICHWORT=STICHWORTANTWORT(EINGABE,STIW); 
    C=STIW(STICHWORT).FLG; 
    THEMACOUNT=THEMACOUNT-1; 
    IF C=='*' AND THEMACOUNT>0 THEN STICHWORT=THEMA;FIN; 
    IF C=='!' THEN THEMA=STICHWORT;THEMACOUNT=4;FIN; 

    ANTWORT=ALTEANTWORT; 
    TO 4 WHILE ANTWORT==ALTEANTWORT REPEAT 
      ANTWORT=ANTWORTSATZ(STIW(STICHWORT)); 
      END; 

    CALL SENDEN(ANTW(ANTWORT)); 

    END;  /* OF REPEAT */ 
  END;    /* OF TASK   */ 

MODEND;