examples/library/ncurses_life.pir

   1 s# Copyright (C) 2001-2008, The Perl Foundation.
   2 # $Id$
   3
   4 =head1 NAME
   5
   6 examples/library/ncurses_life.pir - Conway's Game of Life (ncurses version)
   7
   8 =head1 SYNOPSIS
   9
  10     % ./parrot examples/library/ncurses_life.pir examples/library/acorn.l
  11
  12 =head1 DESCRIPTION
  13
  14 An C<ncurses> version of Conway's Life. F<acorn.l> is a I<life> file.
  15
  16 This version can load F<life.l> files (#P, #A, #R formats only). You get
  17 a lot of .l files by installing C<xlife>.
  18
  19 =head1 COMMANDS
  20
  21 =over 4
  22
  23 =item C<q>, C<Q>
  24
  25 Quit.
  26
  27 =item C<8>, C<2>, C<UP>, C<DOWN>
  28
  29 Move world up or down.
  30
  31 =item C<4>, C<6>, C<LEFT>, C<RIGHT>
  32
  33 Move world left or right
  34
  35 =item C<5>, C<HOME>
  36
  37 Center world.
  38
  39 =item C<g>
  40
  41 Toggle running the game.
  42
  43 =item C<o>
  44
  45 Single step one generation.
  46
  47 =item C<s>
  48
  49 Run slower.
  50
  51 =item C<f>
  52
  53 Run faster.
  54
  55 =back
  56
  57 =cut
  58
  59 .sub _MAIN :main
  60         .param pmc argv
  61         # the command line
  62         load_bytecode "library/ncurses.pasm"
  63 # should autogenerate these
  64 .globalconst int KEY_DOWN = 258
  65 .globalconst int KEY_UP   = 259
  66 .globalconst int KEY_LEFT = 260
  67 .globalconst int KEY_RIGHT= 261
  68 .globalconst int KEY_HOME = 262
  69         # set generation count
  70         .const int MAX_GEN = 5000
  71         # kill the space ship flag
  72         .const int COLLIDE = 1
  73
  74         .local int GEN_COUNT
  75         .local num START_TIME
  76         .local num CUR_TIME
  77         .local num TIME_DIFF
  78         .local num GPS
  79         .local int SUPRESS_PRINT
  80         .local pmc CURS_SET
  81         .local pmc ENDWIN
  82         .local pmc DISPLAY
  83         .local pmc STDSCR
  84         .local int size
  85         .local int stop
  86         .local int sleep_lim
  87         .local int x_offs
  88         .local int y_offs
  89
  90
  91         # 15 * sizef is real size of world
  92         .const int sizef = 8
  93         # delay in usec
  94         .local int delay
  95         delay = 20000
  96
  97         # Note the time
  98         time START_TIME
  99
 100         # If true, we don't print
 101         SUPRESS_PRINT = 0
 102         stop = 0                # -1 start with <g>o
 103         x_offs = 0
 104         y_offs = 0
 105
 106         ENDWIN = global "ncurses::endwin"
 107         CURS_SET = global "ncurses::curs_set"
 108
 109         size = 15 * sizef
 110         .local string err
 111         null err
 112
 113         $I0 = argv
 114         if $I0 <= 1 goto def_world
 115         (S15, err) = _load_file(argv, size)
 116         length $I0, err
 117         if $I0, print_err
 118         goto start_curses
 119
 120 def_world:
 121         S15 = _def_world(sizef, size, COLLIDE)
 122
 123 start_curses:
 124         STDSCR = _init_curses()
 125
 126         GEN_COUNT = 0
 127
 128 loop:
 129         _dump(S15, SUPRESS_PRINT, x_offs, y_offs, size, GEN_COUNT, STDSCR, delay)
 130
 131         if GEN_COUNT >= MAX_GEN goto getout
 132         (stop, x_offs, y_offs, delay) = _check_key(stop, x_offs, y_offs, delay)
 133
 134         if stop != -2 goto not_one
 135         stop = -1
 136         goto gen_one
 137 not_one:
 138         if stop < 0 goto no_gen
 139         if stop goto getout
 140 gen_one:
 141         inc GEN_COUNT
 142         I31 = GEN_COUNT % 100
 143         if I31 goto skip
 144         printerr "."
 145
 146 skip:
 147         (S15, stop) = _generate(S15, size, stop)
 148 no_gen:
 149         branch loop
 150
 151 getout:
 152         CURS_SET(1)
 153         ENDWIN()
 154         time CUR_TIME
 155         TIME_DIFF = CUR_TIME - START_TIME
 156
 157         # sleeping invalidates these data
 158         print "\n"
 159         print GEN_COUNT
 160         print " generations in "
 161         print TIME_DIFF
 162         print " seconds. "
 163         GPS = GEN_COUNT / TIME_DIFF
 164
 165         print GPS
 166         print " generations/sec\n"
 167
 168         interpinfo I1, 1
 169         print "A total of "
 170         print I1
 171         print " bytes were allocated\n"
 172
 173         interpinfo I1, 2
 174         print "A total of "
 175         print I1
 176         print " DOD runs were made\n"
 177
 178         interpinfo I1, 3
 179         print "A total of "
 180         print I1
 181         print " collection runs were made\n"
 182
 183         interpinfo I1, 10
 184         print "Copying a total of "
 185         print I1
 186         print " bytes\n"
 187
 188         interpinfo I1, 5
 189         print "There are "
 190         print I1
 191         print " active Buffer structs\n"
 192
 193         interpinfo I1, 7
 194         print "There are "
 195         print I1
 196         print " total Buffer structs\n"
 197
 198         end
 199
 200 print_err:
 201         printerr "ERROR: "
 202         printerr err
 203         printerr "\n"
 204         exit 1
 205 .end
 206
 207
 208 # S15 has the incoming string, S0 is scratch
 209 .sub _dump
 210         .param string world
 211         .param int SUPRESS_PRINT
 212         .param int x_offs
 213         .param int y_offs
 214         .param int size
 215         .param int GEN_COUNT
 216         .param pmc STDSCR
 217         .param int delay
 218
 219         if SUPRESS_PRINT goto dumpend
 220
 221         .local pmc WCLEAR
 222         .local pmc MVWADDSTR
 223         .local pmc MVWADDCH
 224         .local pmc WREFRESH
 225
 226         WCLEAR     = global "ncurses::wclear"
 227         MVWADDSTR  = global "ncurses::mvwaddstr"
 228         MVWADDCH   = global "ncurses::mvwaddch"
 229         WREFRESH   = global "ncurses::wrefresh"
 230
 231         WCLEAR(STDSCR)
 232         MVWADDSTR(STDSCR, 0, 0, "Generation: ")
 233         $S0 = GEN_COUNT
 234         MVWADDSTR(STDSCR, 0, 13, $S0)
 235
 236         $I0 = size * y_offs
 237         $I0 = $I0 + x_offs
 238         .local int CHARACTER_OFFSET
 239         CHARACTER_OFFSET = $I0
 240         .local int CHAR_POS
 241         CHAR_POS = 0
 242         .local int total
 243         total = size * size
 244         .local int cols
 245         .local int rows
 246         .local pmc ENV
 247         ENV = new Env
 248         $S0 = ENV["COLUMNS"]
 249         cols = $S0
 250         if cols, checklines
 251         cols = 80
 252  checklines:
 253         $S0 = ENV["LINES"]
 254         rows = $S0
 255         if rows, donelines
 256         rows = 24
 257  donelines:
 258         .local int X_COORD
 259         .local int Y_COORD
 260 printloop:
 261         # TODO skip unprintable out of screen
 262         if CHARACTER_OFFSET >= total goto dumpend
 263
 264         substr_r $S0, world, CHARACTER_OFFSET, 1
 265         if $S0 != "*" goto incit
 266         X_COORD = CHAR_POS % size
 267         Y_COORD = CHAR_POS / size
 268         Y_COORD = Y_COORD + 2
 269         if X_COORD > cols goto incit
 270         if Y_COORD > rows goto dumpend
 271         MVWADDCH(STDSCR, Y_COORD, X_COORD, 42) # behold, the lowly star
 272
 273 incit:  inc CHARACTER_OFFSET
 274         inc CHAR_POS
 275         if  CHARACTER_OFFSET < total goto printloop
 276
 277         WREFRESH(STDSCR)
 278
 279         if delay < 100 goto dumpend
 280         # as we gonna sleep here, lets burn some cycles to
 281         # check if usleep is available
 282         null $P0
 283         .local pmc USLEEP
 284         dlfunc USLEEP, $P0, "usleep", "vi"
 285         $I0 = defined USLEEP
 286         if $I0 goto usleep
 287         sleep 1
 288         goto dumpend
 289 usleep:
 290         USLEEP(delay)
 291 dumpend:
 292         .return()
 293 .end
 294
 295 .sub _init_curses
 296         .local pmc INITSCR
 297         .local pmc START_COLOR
 298         .local pmc INIT_PAIR
 299         .local pmc COLOR_PAIR
 300         .local pmc WATTRON
 301         .local pmc CURS_SET
 302         .local pmc NODELAY
 303         .local pmc KEYPAD
 304         .local pmc STDSCR
 305
 306         INITSCR     = global "ncurses::initscr"
 307         START_COLOR = global "ncurses::start_color"
 308         INIT_PAIR   = global "ncurses::init_pair"
 309         COLOR_PAIR  = global "ncurses::COLOR_PAIR"
 310         WATTRON     = global "ncurses::wattron"
 311         CURS_SET    = global "ncurses::curs_set"
 312         NODELAY     = global "ncurses::nodelay"
 313         KEYPAD      = global "ncurses::keypad"
 314
 315         STDSCR = INITSCR()
 316
 317         START_COLOR()
 318
 319         # Color pair 1, dark green fg, black background
 320         INIT_PAIR(1, 2, 0)
 321         $I0 = COLOR_PAIR(1)
 322
 323         # We pass what's returned from COLOR_PAIR straight on
 324         WATTRON(STDSCR, $I0)
 325
 326         CURS_SET(0)                     # turn off cursor
 327         NODELAY(STDSCR, 1)      # set nodelay mode
 328         KEYPAD(STDSCR, 1)       # set keypad mode
 329
 330         .return(STDSCR)
 331 .end
 332
 333 # in: world (string)
 334 #     size
 335 # out new world
 336 #     stop
 337 .sub _generate
 338         .param string world
 339         .param int size
 340         .param int stop
 341
 342 #print "World:\n"
 343 #print world
 344 #print "\n"
 345 #sleep 3
 346
 347         .local int len
 348         .local int pos
 349         .local int count
 350         .local int check        # pos in world
 351         .local string new_world
 352         length len, world
 353         # allocate new world with all space
 354         repeat new_world, " ", len
 355         pos = 0
 356 genloop:
 357         count = 0
 358 NW:
 359         check = -size
 360         dec check
 361         check = check + len
 362         check = check + pos
 363         check = check % len
 364         # $S0 is always overwritten, so reuse it
 365         substr_r $S0, world, check, 1
 366         if $S0 != "*" goto North
 367         inc count
 368 North:
 369         check = -size
 370         check = check + len
 371         check = check + pos
 372         check = check % len
 373         substr_r $S0, world, check, 1
 374         if $S0 != "*" goto NE
 375         inc count
 376 NE:
 377         check = -size
 378         inc check
 379         check = check + len
 380         check = check + pos
 381         check = check % len
 382         substr_r $S0, world, check, 1
 383         if $S0 != "*" goto West
 384         inc count
 385 West:
 386         check = -1
 387         check = check + len
 388         check = check + pos
 389         check = check % len
 390         substr_r $S0, world, check, 1
 391         if $S0 != "*" goto East
 392         inc count
 393 East:
 394         check = 1
 395         check = check + len
 396         check = check + pos
 397         check = check % len
 398         substr_r $S0, world, check, 1
 399         if $S0 != "*" goto SW
 400         inc count
 401 SW:
 402         check = size
 403         dec check
 404         check = check + len
 405         check = check + pos
 406         check = check % len
 407         substr_r $S0, world, check, 1
 408         if $S0 != "*" goto South
 409         inc count
 410 South:
 411         check = size
 412         check = check + len
 413         check = check + pos
 414         check = check % len
 415         substr_r $S0, world, check, 1
 416         if $S0 != "*" goto SE
 417         inc count
 418 SE:
 419         check = size
 420         inc check
 421         check = check + len
 422         check = check + pos
 423         check = check % len
 424         substr_r $S0, world, check, 1
 425         if $S0 != "*" goto checkl
 426         inc count
 427 checkl:
 428         substr_r $S0, world, pos, 1
 429         if $S0 == "*" goto check_alive
 430
 431 # If eq 3, put a star in else a space
 432 check_dead:
 433         if count == 3 goto star
 434         branch space
 435
 436 check_alive:
 437         if count < 2 goto space
 438         if count > 3 goto space
 439 star:
 440         substr new_world, pos, 1, "*"
 441 space:  # is space already
 442         inc pos
 443         if pos < len goto genloop
 444 done:
 445         if  new_world != world goto dif
 446            sleep 2
 447            stop = 1
 448 dif:
 449         .return(new_world, stop)
 450 .end
 451
 452 .sub _def_world
 453         .param int sizef
 454         .param int size
 455         .param int COLLIDE
 456         set S17,  "               "
 457         $I0 = sizef - 1
 458         unless $I0 goto nosize
 459         S16 = ""
 460         repeat S16, S17, $I0
 461 nosize:
 462         set S0,  "               "
 463         set S1,  "               "
 464         set S2,  "               "
 465         set S3,  "               "
 466         set S4,  "  **           "
 467         set S5,  "*    *         "
 468         set S6,  "      *        "
 469         set S7,  "*     *        "
 470         set S8,  " ******        "
 471         set S9,  "               "
 472         set S10, "               "
 473         set S11, "               "
 474         if COLLIDE goto col
 475         set S12, "               "
 476         set S13, "               "
 477         set S14, "               "
 478         goto nocol
 479 col:
 480         set S12, "             * "
 481         set S13, "              *"
 482         set S14, "            ***"
 483 nocol:
 484         .local string world
 485         set world, ""
 486         concat world, S0
 487         concat world, S16
 488         concat world, S1
 489         concat world, S16
 490         concat world, S2
 491         concat world, S16
 492         concat world, S3
 493         concat world, S16
 494         concat world, S4
 495         concat world, S16
 496         concat world, S5
 497         concat world, S16
 498         concat world, S6
 499         concat world, S16
 500         concat world, S7
 501         concat world, S16
 502         concat world, S8
 503         concat world, S16
 504         concat world, S9
 505         concat world, S16
 506         concat world, S10
 507         concat world, S16
 508         concat world, S11
 509         concat world, S16
 510         concat world, S12
 511         concat world, S16
 512         concat world, S13
 513         concat world, S16
 514         concat world, S14
 515         concat world, S16
 516         $I1 = size * $I0
 517         repeat S16, S17, $I1
 518         concat world, S16
 519         .return(world)
 520 .end
 521
 522 .sub _load_file
 523         .param pmc argv
 524         .param int size
 525
 526         .local string world
 527         .local string err
 528         world = ""
 529         .local string file
 530         file = argv[1]
 531         err = "File not found " . file
 532         .local pmc io
 533         open io, file, "<"
 534         $I0 = defined io
 535         unless $I0 goto nok
 536         null err
 537         .local string line
 538         $I0 = size * size
 539         repeat world, " ", $I0
 540         .local int pos
 541         $I0 = size / 2
 542         $I1 = $I0 * $I0
 543         pos = $I0 + $I1
 544         .local int len
 545         .local int format
 546         format = 0
 547         .const int PICTURE = 1
 548         .const int ABS     = 2
 549         .const int REL     = 3
 550         .local   pmc points
 551
 552 loop:
 553         readline line, io
 554         length len, line
 555         unless len goto out
 556         $S0 = line[0]
 557         eq $S0, "#", check_format
 558         chopn line, 1           # \n
 559         dec len
 560         if format != PICTURE goto not_pic
 561         substr world, pos, len, line
 562         pos = pos + size
 563         goto loop
 564 not_pic:
 565         if format != ABS goto not_abs
 566         goto do_rel
 567 not_abs:
 568         if format != REL goto not_rel
 569 do_rel:
 570         # parse \s(\d+) (\d+)
 571         # I really want PCRE or better inside Parrot :)
 572         .local int s
 573         .local int start
 574         .local int in_digit
 575         in_digit = 0
 576         s = 0
 577 get_d:
 578         if s >= len goto space
 579         $S0 = line[s]
 580         ord $I0, $S0
 581         if $I0 == 32 goto space
 582         if $I0 == 9  goto space
 583         if $I0 == 43 goto cont_d        # ignore +
 584         if $I0 == 45 goto dig           # sing, start dig
 585         if $I0 >= 0x30 goto dig1
 586         err = "Found junk at " . $S0
 587         goto out
 588
 589 dig1:
 590         if $I0 <= 0x39 goto dig
 591         err = "Found junk at " . $S0
 592         goto out
 593
 594 dig:    if in_digit == 1 goto cont_d
 595         if in_digit == 3 goto cont_d
 596         start = s
 597         inc in_digit
 598
 599 cont_d:
 600         inc s
 601         goto get_d
 602 space:
 603         if in_digit == 0 goto cont_d
 604         if in_digit == 2 goto cont_d
 605         inc in_digit
 606         $I1 = s - start
 607         substr $S1, line, start, $I1
 608         $I2 = $S1
 609         push points, $I2
 610         if s >= len goto loop
 611         inc s
 612         goto get_d
 613
 614 end_d:
 615         goto loop
 616
 617 not_rel:
 618         err = "Unhandled file format"
 619         goto out
 620
 621 check_format:
 622         $S0 = line[1]
 623         if $S0 == "C" goto loop # comment
 624         if $S0 == "#" goto loop # comment
 625         if $S0 == "N" goto loop # name of pattern
 626         if $S0 == "O" goto loop # owner
 627         if $S0 == "U" goto loop # use format
 628         unless format goto f1
 629         err = "Mixed formats found"
 630         goto out
 631 f1:
 632         if $S0 != "P" goto not_P        # picture
 633         format = PICTURE
 634 not_P:
 635         if $S0 != "A" goto not_A        # absolute
 636         format = ABS
 637         points = new 'ResizableIntegerArray'
 638 not_A:
 639         if $S0 != "R" goto not_R        # relative
 640         format = REL
 641         points = new 'ResizableIntegerArray'
 642 not_R:
 643         goto loop
 644
 645 out:
 646         close io
 647         if format == PICTURE goto done
 648         # we have an array of x,y pairs now
 649         # find min, max
 650         .local int min_x
 651         .local int min_y
 652         .local int max_x
 653         .local int max_y
 654         min_x = 99999
 655         min_y = 99999
 656         max_x = -99999
 657         max_y = -99999
 658         .local int x
 659         .local int y
 660         .local int len
 661         len = points
 662         s = 0
 663 lp:
 664         x = points[s]
 665         inc s
 666         y = points[s]
 667         inc s
 668         if x >= min_x goto no_min_x
 669         min_x = x
 670 no_min_x:
 671         if x <= max_x goto no_max_x
 672         max_x = x
 673 no_max_x:
 674         if y >= min_y goto no_min_y
 675         min_y = y
 676 no_min_y:
 677         if y <= max_y goto no_max_y
 678         max_y = y
 679 no_max_y:
 680         if s < len goto lp
 681
 682 #       printerr min_x
 683 #       printerr ", "
 684 #       printerr min_y
 685 #       printerr ", "
 686 #       printerr max_x
 687 #       printerr ", "
 688 #       printerr max_y
 689 #       printerr "\n\n"
 690
 691         # now fill world
 692         s = 0
 693 lp2:
 694         x = points[s]
 695         inc s
 696         y = points[s]
 697         inc s
 698         x = x - min_x
 699         y = y - min_y
 700 #       printerr x
 701 #       printerr ", "
 702 #       printerr y
 703 #       printerr "\n"
 704         .local int c
 705         c = y * size
 706         c = x + c
 707         # TODO abs/rel and bounds checking
 708         world[c] = "*"
 709         if s < len goto lp2
 710 done:
 711 nok:
 712         .return(world, err)
 713 .end
 714
 715 .sub _check_key
 716         .param int stop
 717         .param int x_offs
 718         .param int y_offs
 719         .param int delay
 720
 721         .local int key
 722         .local pmc GETCH
 723         GETCH = global "ncurses::getch"
 724         key = GETCH()
 725         if key == KEY_LEFT goto is_4
 726         if key == KEY_RIGHT goto is_6
 727         if key == KEY_UP goto is_8
 728         if key == KEY_DOWN goto is_2
 729         if key == KEY_HOME goto is_5
 730         if key != 113 goto no_q
 731         stop = 1
 732 no_q:
 733         if key != 81 goto no_Q
 734         stop = 1
 735         goto key_done
 736 no_Q:
 737         if key != 0x38 goto no_8
 738 is_8:
 739         y_offs = y_offs + 10
 740         goto key_done
 741 no_8:
 742         if key != 0x32 goto no_2
 743 is_2:
 744         if y_offs < 10 goto key_done
 745         y_offs = y_offs - 10
 746         goto key_done
 747 no_2:
 748         if key != 0x34 goto no_4
 749 is_4:
 750         x_offs = x_offs + 10
 751         goto key_done
 752 no_4:
 753         if key != 0x36 goto no_6
 754 is_6:
 755         if x_offs < 10 goto key_done
 756         x_offs = x_offs - 10
 757         goto key_done
 758 no_6:
 759         if key != 0x35 goto no_5
 760 is_5:
 761         x_offs = 0
 762         y_offs = 0
 763         goto key_done
 764 no_5:
 765         if key != 103 goto no_g
 766         if stop == 0 goto g0
 767         stop = 0
 768         goto key_done
 769 g0:
 770         stop = -1
 771         goto key_done
 772 no_g:
 773         if key != 111 goto no_o
 774         stop = -2
 775         goto key_done
 776 no_o:
 777         if key != 115 goto no_s
 778         stop = 0
 779         delay = delay * 2
 780         goto key_done
 781 no_s:
 782         if key != 102 goto no_f
 783         stop = 0
 784         delay = delay / 2
 785         if delay goto key_done
 786         delay = 1
 787         goto key_done
 788 no_f:
 789
 790 key_done:
 791         .return(stop, x_offs, y_offs, delay)
 792 .end
 793
 794 =head1 SEE ALSO
 795
 796 F<examples/library/acorn.l>, F<examples/pasm/life.pasm>,
 797 F<library/ncurses.pasm>, F<library/ncurses.declarations>.
 798
 799 =cut
 800
 801 # Local Variables:
 802 #   mode: pir
 803 #   fill-column: 100
 804 # End:
 805 # vim: expandtab shiftwidth=4 ft=pir: