Тишинуша Гамимеря (spamsink) wrote,
Тишинуша Гамимеря
spamsink

Этюд для программистов-шампольонов

Под катом приведена вроде бы цельная программа на мёртвом языке POP-2, делающая вид, что играет в крестики-нолики 4х4х4. Пока не выяснено, имеется ли в нашем распоряжении работающий компилятор для этого конкретного диалекта языка. Желающим предлагается по наитию перевести эту программу на какой-нибудь более современный язык и выяснить, насколько сильно она играет.

Не удивляйтесь, программа начинается и кончается по нынешним меркам внезапно (но с обоих концов логично, так что, по всей видимости, ничего не утрачено).

ERASE->CUCHOUT;
VARS MYLIST FORCEMOVES LINES POINTS OWNER LENS USEDPTS
     BOARD A1 LINEO THISLINE COUNT1 COUNT2 X3 X2 COUNT3 X1
     A3 A2 COUNT SCALE RANSEED
     FORMLINES GETSPACE MOVEVALUE VALUES
     TESTFORCE FREEPT FINDL UNMOVE UNWRAP MOVEIT HISMOVE
     PRINTBOARD MYITEMREAD CNTFOR;
  
FUNCTI SETUP;VARS X;
  INIT(64)->BOARD; INIT(64)->USEDPTS;
  INIT(76)->LENS;INIT(76)->OWNER;
  INIT(64)->POINTS; 76->X;
L1: 4->SUBSCR(X,LENS); 0->SUBSCR(X,OWNER);
  IF X<65 THEN
    INIT(8)->SUBSCR(X,POINTS); 1->SUBSCR(X,USEDPTS);
     0->SUBSCR(X,BOARD)
  CLOSE;
  X-1->X; IF X>0 THEN GOTO L1 CLOSE;
  INIT(76)->LINES; .FORMLINES;
  NIL->FORCEMOVES; 0->MYLIST;
END;
  
FUNCTI MOVE X A B;VARS T U V W Y Z;
   SUBSCR(X,POINTS)->Y; 1->Z;0->U;
  IF B THEN .GETSPACE->T; CLOSE;
L1: SUBSCR(Z,Y)->W;
  IF W<0 THEN
    IF B THEN T;X CLOSE;
    0->SUBSCR(X,USEDPTS); U EXIT;
  SUBSCR(W,LENS)->V;
  IF B THEN V+SUBSCR(W,OWNER)->SUBSCR(Z,T) CLOSE;
  IF SUBSCR(W,OWNER)=0 THEN
    IF V=0 THEN GOTO L2 CLOSE;
    A->SUBSCR(W,OWNER);3->SUBSCR(W,LENS);
  ELSEIF SUBSCR(W,OWNER)=A THEN 
   V-1->SUBSCR(W,LENS);
   IF V=1 THEN 1->U CLOSE;
  ELSE 0->SUBSCR(W,OWNER);0->SUBSCR(W,LENS);
  CLOSE;
L2: Z+1->Z; GOTO L1;
END;
  
FUNCTI LINEFORM; VARS Y Z;
  4->COUNT1; INIT(4)->THISLINE;
L1: X+1->SUBSCR(COUNT1,THISLINE);
     SUBSCR(X+1,USEDPTS)->Y; SUBSCR(X+1,POINTS)->Z;
   LINEO->SUBSCR(Y,Z); -1->SUBSCR(Y+1,Z);
   Y+1->SUBSCR(X+1,USEDPTS); X+A1->X;
   COUNT1-1->COUNT1; IF COUNT1>0 THEN GOTO L1 CLOSE;
   THISLINE->SUBSCR(LINEO,LINES);
  LINEO+1->LINEO
END;
  
FUNCTI GETSPACE;
  IF MYLIST=0 THEN INIT(8)
  ELSE MYLIST; SUBSCR(8,MYLIST)->MYLIST
  CLOSE;
END;
  
FUNCTI FREESPACE X;
  MYLIST->SUBSCR(8,X);X->MYLIST;
END;
  
FUNCTI FORMLINES;
  1->A1;4->A2;16->A3;1->LINEO;
L1: 0->X;1->X1;4->COUNT3;
L5: X->X2;X->X3;
L2: 4->COUNT2;
L3: .LINEFORM;
  X2+A2->X2;
  X2->X;COUNT2-1->COUNT2;
 IF COUNT2>0 THEN GOTO L3 CLOSE;
 X3+A3->X3;X3->X2;X3->X;COUNT3-1->COUNT3;
 IF COUNT3>0 THEN GOTO L2 CLOSE;
 IF X1>0 THEN X1-1->X1;A3;A2;A1;A2+A1;
    A3->A2->A1;0->X;GOTO L5
 CLOSE;
 IF X1=0 THEN X1-1->X1;->X;A1-X-X->A1;X;
   IF A1>0 THEN A1->X
   ELSE -A1->A1;3->X;
   CLOSE;GOTO L5
 CLOSE;
 ->A3->A1->A2;
 IF A1>1THEN GOTO L1 CLOSE;
 0->X; 21->A1; .LINEFORM;
 3->X;19->A1; .LINEFORM;
 12->X;13->A1; .LINEFORM;
 15->X;11->A1; .LINEFORM;
1->X;
L4: 1->SUBSCR(X,USEDPTS);
    X+1->X;IF X<65 THEN GOTO L4 CLOSE;
END;
   
FUNCTI TESTMOVES; VARS X A B C D P1 P2;
  FINDL(1,0)->X;
  IF X/=0 THEN
L4: X.FREEPT->A;
    IF SUBSCR(X,OWNER)=8 THEN A EXIT;
   FINDL(1,X)->B;
   IF B/=0 THEN B->X; GOTO L4 CLOSE;
   IF FORCEMOVES.NULL THEN
L5:    A
   EXIT;
   IF A=HD(FORCEMOVES) THEN GOTO L0 CLOSE;
PR('i}iTE O{ibKY B TESTFORCE');
   NIL->FORCEMOVES;GOTO L5
 CLOSE;
 IF NOT(NULL(FORCEMOVES)) THEN 
L0: HD(FORCEMOVES); TL(FORCEMOVES)->FORCEMOVES;
 EXIT;
 8->P1;16->P2;
  100->CNTFOR;
 IF .TESTFORCE THEN GOTO L0 CLOSE;
 P1;P2->P1;->P2;
  50->CNTFOR;
 IF .TESTFORCE THEN HD(FORCEMOVES); NIL->FORCEMOVES; EXIT;
 INTOF(SCALE* .RANDOM)->COUNT; COUNT->COUNT1;
 IF SCALE>4 THEN SCALE//2->SCALE->X;
 CLOSE;
  -1000000->X; .VALUES; 1->D;
L1: IF D=65 THEN C EXIT;
  IF SUBSCR(D,USEDPTS)=0 THEN GOTO L2 CLOSE;
 MOVEVALUE(D,Y,Z,V,W)->B;
 IF B>X THEN
   COUNT1->COUNT;
L3: B->X;D->C;
   ELSEIF B=X THEN
     IF COUNT>1 THEN COUNT-1->COUNT;GOTO L3 CLOSE;
 CLOSE;
L2: D+1->D; GOTO L1
END;
   
FUNCTI TESTFORCE; VARS X W FIRST;
  CNTFOR-1->CNTFOR;
  0->X;
L4: FINDL(2,X)->X;
   IF X=0 THEN 0 EXIT;
   IF SUBSCR(X,OWNER)=P2 THEN GOTO L4 CLOSE;
   1->FIRST;
   X.FREEPT->Y->W;
L2: MOVE(W,P1,1)->V; MOVE(Y,P2,1)->V;
L3: FINDL(1,0)->Z;
  IF Z>0 THEN
L5:IF SUBSCR(Z,OWNER)=P1 THEN Z.FREEPT::NIL->FORCEMOVES; .UNWRAP EXIT;
   FINDL(1,Z)->V;
   IF V THEN V->Z; GOTO L5 CLOSE;
   MOVE(Z.FREEPT,P1,1)->V;
   FINDL(1,0)->V;
   IF V=0 THEN GOTO L7 CLOSE;
L6:IF SUBSCR(V,OWNER)=P2 THEN
L7:  .UNMOVE; GOTO L1;
   CLOSE;
   FINDL(1,V)->Z;
   IF Z THEN Z->V; GOTO L6 CLOSE;
   MOVE(V.FREEPT,P2,1)->V;
   GOTO L3
CLOSE;
  IF CNTFOR AND .TESTFORCE THEN .UNWRAP EXIT;
L1: .UNMOVE; ->Y; Y.UNMOVE; IF Y/=W THEN GOTO L1 CLOSE;
   IF FIRST THEN
     0->FIRST; X.FREEPT->W->Y; GOTO L2
CLOSE;
  GOTO L4
END
   
FUNCTI UNMOVE T X;VARS Z U V W;
  1->SUBSCR(X,USEDPTS);
  SUBSCR(X,POINTS)->Z; 1->U;
L1: SUBSCR(U,Z)->V;
   IF V<0 THEN FREESPACE(T) EXIT;
   SUBSCR(U,T)->W;
   LOGAND(W,7)->SUBSCR(V,LENS);
   LOGAND(W,24)->SUBSCR(V,OWNER);
  U+1->U; GOTO L1
END;
  
FUNCTI UNWRAP;
L1: .UNMOVE; ->X;X.UNMOVE;
  X::FORCEMOVES->FORCEMOVES;
  IF X/=W THEN GOTO L1 CLOSE;
1 END;
  
FUNCTI FINDL Y X;
L1: X+1->X; IF X=77 THEN 0 EXIT;
   IF SUBSCR(X,LENS)=Y THEN X EXIT;
   GOTO L1;
END;
   
FUNCTI VALUES; VARS X;
  0->Y;0->Z;0->V;0->W;1->X;
L1: IF SUBSCR(X,LENS)=2 THEN
    IF SUBSCR(X,OWNER)=P2 THEN Y+1->Y
    ELSE Z+1->Z
    CLOSE;
 ELSEIF SUBSCR(X,LENS)=3 THEN
    IF SUBSCR(X,OWNER)=P2 THEN V+1->V
    ELSE W+1->W
    CLOSE;
  CLOSE;
  X+1->X; IF X<77 THEN GOTO L1 CLOSE;
END;
  
FUNCTI MOVEVALUE X A B C D;VARS W Y Z;
SUBSCR(X,POINTS)->X; 1->Z;
L1: SUBSCR(Z,X)->W;
   IF W<0 THEN C-4 *D+16 *A-32  *B EXIT;
   SUBSCR(W,LENS)->Y;
   IF Y=4 THEN C+1->C
   ELSEIF Y=3 THEN
    IF SUBSCR(W,OWNER)=P2 THEN A+1->A ELSE D-1->D CLOSE;
   ELSEIF Y=2 THEN
    IF SUBSCR(W,OWNER)=P1 THEN B-1->B CLOSE
   CLOSE;
  Z+1->Z;GOTO L1
END;
  
FUNCTI FREEPT X;VARS Y Z;
1->Y; SUBSCR(X,LINES)->X;
  L1: SUBSCR(Y,X)->Z;
  IF SUBSCR(Z,USEDPTS)=1 THEN Z CLOSE;
Y+1->Y; IF Y<5 THEN GOTO L1 CLOSE;
END;
  
FUNCTI MOVEIT X; MOVE(X,8,0);
  8->SUBSCR(X,BOARD);
  (((X-1)//4)//4).PR;.PR;.PR; .PRINTBOARD;
END;
   
FUNCTI HISMOVE; VARS L M N;
L0: PRSTRING('YOUR MOVE');
L1: .MYITEMREAD->L; IF L="RESIGN" THEN L EXIT;
   IF L="HELP" THEN
     IF NOT(NULL(FORCEMOVES)) THEN
      PRSTRING('I CAN WIN NO MATTER WHAT YOU DO.');
      GOTO L0
     CLOSE;
        FINDL(1,0)->L;IF L>0 THEN L.FREEPT->C;GOTO L8 CLOSE;
      16->P1;8->P2;
  100->CNTFOR;
      IF TESTFORCE() THEN
        LENGTH(FORCEMOVES)->M;HD(FORCEMOVES)->N;
        PRSTRING('YOU CAN FORCE A WIN IN');PR(M);
        PRSTRING(' MOVES, STARTING AT');
L5:    (((N-1)//4)//4).PR;.PR;.PR;
        1.NL;NIL->FORCEMOVES; GOTO L0
      CLOSE;
      P1;P2->P1;->P2;
  50->CNTFOR;
      IF .TESTFORCE THEN
       HD(FORCEMOVES)->N;
       PRSTRING('I AM IN A STRONG POSITION. HOWEVER, TRY');
       GOTO L5
      CLOSE;
      -1000000->X; .VALUES; 1->D;
L6: IF D=65 THEN
L8:      PRSTRING('TRY');(((C-1)//4)//4).PR;.PR;.PR;
         1.NL;GOTO L0
       CLOSE;
      IF SUBSCR(D,USEDPTS)=0 THEN GOTO L7 CLOSE;
      MOVEVALUE(D,Y,Z,V,W)->B;
     IF B>X THEN B->X; D->C CLOSE;
L7: D+1->D; GOTO L6
  CLOSE;
  IF ISCOMPND(L) THEN GOTO L1 CLOSE;
  IF L<0 OR L>3 THEN
L2:      PRSTRING('NO SUCH POSITION. PLEASE RETYPE.');
     GOTO L0;
    CLOSE;
L3: .MYITEMREAD->M;
    IF ISCOMPND(M) THEN GOTO L3 CLOSE;
    IF M<0 OR M>3 THEN GOTO L2 CLOSE;
L4: .MYITEMREAD->N;
    IF ISCOMPND(N) THEN GOTO L4 CLOSE;
    IF N<0 OR N>3 THEN GOTO L2 CLOSE;
    16*L+4*M+N+1->L;
    IF SUBSCR(L,BOARD)/=0 THEN
      PRSTRING('THAT POSITION IS ALREADY OCCUPIED. STOP
TRYING TO CHEAT.');
    GOTO L0
CLOSE;
    MOVE(L,16,0);
    16->SUBSCR(L,BOARD);
END;
    
FUNCTI PRINTBOARD; VARS X Y Z;
   2.NL;5.SP;0.PR;8.SP;1.PR;8.SP;2.PR;8.SP;3.PR;
   2.NL;4->X;
L1: 2.SP;0.PR;1.PR;2.PR;3.PR;X-1->X; IF X>0 THEN GOTO L1 CLOSE;
   0->Y;1->Z;
L2: 1.NL;Y.PR;4->X;4->W;
L3: 1.SP;
   IF SUBSCR(Z,BOARD)=0 THEN PR(".")
   ELSEIF SUBSCR(Z,BOARD)=16 THEN PR("X")
   ELSE PR("O")
   CLOSE;
   Z+1->Z;X-1->X;
   IF X>0 THEN GOTO L3 CLOSE;
   W-1->W;
IF W>0 THEN 4->X;Z+12->Z;2.SP;GOTO L3 CLOSE;
   Y+1->Y;
   IF Y<4 THEN Z-48->Z;GOTO L2 CLOSE;
   2.NL;
END;
   
ITEMREAD->MYITEMREAD;
   
FUNCTI PLAY;
    .SETUP; INTOF(100*POPTIM())->RANSEED;
L1: 1.NL;
  PRSTRING('DO YOU KNOW HOW TO PLAY AGAINST THIS PROGRAM');
    .MYITEMREAD->X;
    IF X="YES" THEN GOTO L3 CLOSE;
L2: PRSTRING('THE GAME IS PLAYED ON A 4*4*4 CUBE. THE OBJECT
BEING TO PLACE 4 PIECES IN A STRAIGHT LINE; YOUR
PIECES ARE SHOWN AS X , MINE AS O . TO MAKE A
MOVE YOU HAVE TO TYPE IN 3 NUMBERS, INDICATING
PLANE, ROW AND COLUMN; EACH IN THE RANGE 0 TO 3.
THUS IN THE BOARD SHOWN BELOW, YOU HAVE A PIECE
AT 1 3 2  AND I HAVE ONE AT 2 0 3.');
   16->SUBSCR(31,BOARD); 8->SUBSCR(36,BOARD);
   .PRINTBOARD;
    0->SUBSCR(31,BOARD); 0->SUBSCR(36,BOARD);
'YOU CAN ASK THEN COMPUTER TO SUGGEST A MOVE BY TYPING  HELP
AND CAN CONCEDE BY TYPING  RESIGN
'.PRSTRING;
L3: 'DO YOU WANT TO START
'.PRSTRING;
   .MYITEMRE->X; .PRINTBOARD;
   IF X="YES" THEN 16->SCALE; GOTO L4 ELSE 8->SCALE; GOTO L6 CLOSE;
L4: .HISMOVE->X;
    IF X="RESIGN" THEN
     IF NULL(FORCEMOVES) THEN
      PRSTRING('I HAD NOT REALISED THAT MY POSITION WAS IMPREGNABLE.
')  ELSE  PRSTRING('FAIR ENOUGH.  ')
   CLOSE;
   GOTO L5
   CLOSE;
IF X THEN .PRINTBOARD; PRSTRING('YOU WIN.  ');GOTO L5 CLOSE;
L6: 1.NL;PRSTRING('MY MOVE'); .TESTMOVES;
  IF .MOVEIT THEN 1.NL;PRSTRING('I WIN.  '); GOTO L5 CLOSE;
  GOTO L4;
L5: PRSTRING('DO YOU WANT TO PLAY AGAIN');
  .MYITEMREAD->X;
   IF X="YES" THEN .SETUP; GOTO L3 CLOSE;
   PRSTRING('BACK TO POP2 THEN');
END;
   
VARS RANSEED;FUNCTI RANDOM;
(125*RANSEED+1)//16384; .ERASE;->RANSEED;
RANSEED/16384;END;
CHAROUT->CUCHOUT;4.NL;
PRSTRING('TO ENTER PROGRAM, TYPE  FOURS;
');
VARS OPERATION 1 FOURS;
PLAY->NONOP FOURS;


Публикуется, если верить гуглопоиску по текстовым сообщениям, впервые.
Tags: retrocomputing
Subscribe

  • (no subject)

    Только что, благодаря пандоровской системе Deep Cuts, я впервые в жизни услышал песню Азнавура Hier Encore (точнее, её английский вариант…

  • Про консульство РФ в Сан Франциско

    Статья в местной газете ...The first Russian consulate in the United States opened in San Francisco in 1852. It is Russia’s oldest and most…

  • Сдохнуть можно!

    Кокосы могут быть смертельны не только когда они падают на голову. Один глоток жидкости из испорченного кокоса - и труп. Насколько я понимаю,…

  • Post a new comment

    Error

    Anonymous comments are disabled in this journal

    default userpic

    Your reply will be screened

    Your IP address will be recorded 

  • 12 comments

  • (no subject)

    Только что, благодаря пандоровской системе Deep Cuts, я впервые в жизни услышал песню Азнавура Hier Encore (точнее, её английский вариант…

  • Про консульство РФ в Сан Франциско

    Статья в местной газете ...The first Russian consulate in the United States opened in San Francisco in 1852. It is Russia’s oldest and most…

  • Сдохнуть можно!

    Кокосы могут быть смертельны не только когда они падают на голову. Один глоток жидкости из испорченного кокоса - и труп. Насколько я понимаю,…