; Fun stuff...
; CARPET, ESPGAME, LAUTO, LAPAT 4/13/02 for HP-IPL/OS 0.39+
; modified 9/27/02, added more lineauto patterns
; modified 8/25/04 to not use LOOP which was removed in 0.58
;--------------------------------------------------
"LOADING CARPET" $PRINT CRLF
OCTAL DEFINE CARPET
#0 S>SR  ;set any SR switch to stop
DO 1 117 +DO RND
IF<0 "*" ELSE " " ENDIF
$PRINT +LOOP CRLF
SR>S UNTIL END
;--------------------------------------------------
"LOADING ESPGAME" $PRINT CRLF
OCTAL DEFINE ESPGAME
DECIMAL
"*** ESP GAME ***" $PRINT CRLF
0 S>Y  ;keep total on Y
0 S>Z  ;keep #correct on Z
DO "THINKING OF A NUMBER FROM 0-9" $PRINT CRLF
0 11 +DO RND
14632 DIV DUP ;rnd and 1 copy on stack
"ENTER YOUR GUESS: " $PRINT CHRIN
60 SUB SUB ;convert to bin, compare
IFZ "  CORRECT!" $PRINT DROP
Z>S INC S>Z  ; increment #correct
ELSE "  WRONG, IT WAS " $PRINT PNUM
ENDIF CRLF
Y>S INC S>Y  ; increment total
+LOOP
"HIT RATE = " $PRINT
Z>S DUP S>Z 144 MUL Y>S DUP S>Y DIV
PNUM "PERCENT" $PRINT CRLF
"KEEP PLAYING? " $PRINT CHRIN CRLF
131 SUB IFZ 0 ELSE 1 ENDIF
UNTIL Y>S DROP Z>S DROP
OCTAL ;or whatever your fav is
END
;--------------------------------------------------
"LOADING LAUTO" $PRINT CRLF
OCTAL DEFINE LAUTO ; Line Automata for HP-IPL/OS
"4-STATE LINE AUTOMATA WITH 3-CELL NEIGHBORHOOD"
$PRINT CRLF "NUMBER OF LINES PER CYCLE: " $PRINT $IN
$LEN IFZ " " $CAT ENDIF $VAL
DUP IFZ DROP 26 "HOW ABOUT 22 DEC" $PRINT CRLF ENDIF
S>Z  ;keep #lines on Z
DO
 "RULE (10 DIGIT STRING OF 0-3): " $PRINT $IN
 $LEN IFZ ;if empty string
  $DROP ;drop the string and
  #1    ;terminate
 ELSE
  #0    ;keep going when it gets to until
  #0 $LEN 12 SUB ;check rule length
  IFNZ
   DROP #1  ;invalid length
  ELSE
   #0 11 +DO  ;validate rule string
    #1  ;start this char out not-ok
    INDEX $GET      ;get char to test for 0-3
    DUP 60 SUB IFZ SWAP DROP #0 SWAP ENDIF
    DUP 61 SUB IFZ SWAP DROP #0 SWAP ENDIF
    DUP 62 SUB IFZ SWAP DROP #0 SWAP ENDIF
        63 SUB IFZ      DROP #0      ENDIF
;now stack=0 if valid, 1 if not
    IFNZ DROP #1 ENDIF  ;throw the switch!
   +LOOP
  ENDIF
  X>>Y  ;stash rule string on Y
  IFNZ    ;if rule was not valid...
   "INVALID RULE" $PRINT CRLF
  ELSE        ;rule was valid....
   ;create initial random line....
   "" #1 117 +DO RND 40000 DIV 60 ADD $APPEND +LOOP
   DO  ;loop until no more requested
    #1 Z>S DUP S>Z +DO  ;perform spec# of generations...
     #0 $LEN DEC +DO  ;print line...
      INDEX $GET
      DUP 60 SUB IFZ 40 PCHR ENDIF  ; " "
      DUP 61 SUB IFZ 56 PCHR ENDIF  ; "."
      DUP 62 SUB IFZ 53 PCHR ENDIF  ; "+"
          63 SUB IFZ 43 PCHR ENDIF  ; "#"
     +LOOP CRLF
     "0" X>>Z    ;start new line off with "guard 0"
     #1 115 +DO ;loop thru the inner part of string...
      #0         ;start a count at 0
      INDEX DEC $GET 60 SUB ADD  ;add val of $(index-1)
      INDEX $GET 60 SUB ADD      ;add val of $(index)
      INDEX INC $GET 60 SUB ADD  ;add val of $(index+1)
      ;stack contains new state for cell, compute from rule..
      Y>>X $GET X>>Y Z>>X $APPEND X>>Z
     +LOOP
     $DROP Z>>X ;make new string current
     60 $APPEND ;add final "guard 0"
    +LOOP
    "MORE? (Y/N) " $PRINT CHRIN CRLF
    131 SUB IFZ #1 ELSE #0 ENDIF
   WHILE  ;more is being requested
   $DROP       ;drop the line
  ENDIF ;valid rule
  Y>>X $DROP  ;discard rule
 ENDIF
UNTIL   ;user has had enough fun
Z>S DROP    ;get rid of #lines per cycle
END
;--------------------------------------------------
"LOADING LAPAT" $PRINT CRLF
OCTAL DEFINE LAPAT
"0020123010 " $PRINT "0012301200 " $PRINT
"0130010200 " $PRINT "0012301100 " $PRINT
"0012130100" $PRINT CRLF
"0302120100 " $PRINT "0003201300 " $PRINT
"0113123000 " $PRINT "0003132000 " $PRINT
"1002132000" $PRINT CRLF
"0020331100 " $PRINT "0003212000 " $PRINT
"0011232000" $PRINT
END
;--------------------------------------------------
"DONE" $PRINT CONSOLE