#
# ncurses_life.imc
#
# Play conway's (no, not *him*. The other conway) game of life

# this version can load life.l files (#P, #A, #R formats only)
# you get a lot of .l files by installing xlife
#
# parrot examples/assembly/ncurses_life.imc examples/assembly/acorn.l
#
# for command keys please consult the pod at the of the file

.pcc_sub _MAIN prototyped
	.param pmc argv
	# the command line
.include "library/ncurses.pasm"
# should autogenerate these
.globalconst int KEY_DOWN = 258
.globalconst int KEY_UP   = 259
.globalconst int KEY_LEFT = 260
.globalconst int KEY_RIGHT= 261
.globalconst int KEY_HOME = 262
	# set generation count
        .const int MAX_GEN = 5000
	# kill the space ship flag
        .const int COLLIDE = 1

	.local int GEN_COUNT
	.local float START_TIME
	.local float CUR_TIME
	.local float TIME_DIFF
	.local float GPS
	.local int SUPRESS_PRINT
	.local pmc CURS_SET
	.local pmc ENDWIN
	.local pmc DISPLAY
	.local pmc STDSCR
	.local int size
	.local int stop
	.local int sleep_lim
	.local int x_offs
	.local int y_offs


	# 15 * sizef is real size of world
	.const int sizef = 8
	# delay in usec
	.sym int delay
	delay = 20000

	# Note the time
	time START_TIME

	# If true, we don't print
	SUPRESS_PRINT = 0
	stop = 0		# -1 start with <g>o
	x_offs = 0
	y_offs = 0

	ENDWIN = global "ncurses::endwin"
	CURS_SET = global "ncurses::curs_set"

	size = 15 * sizef
	.local string err
	null err

	$I0 = argv
	if $I0 <= 1 goto def_world
	.sym Sub load
	newsub load, .Sub, _load_file
	.pcc_begin prototyped
	.arg argv
	.arg size
	.pcc_call load
retl:
	.result S15
	.result err
	.pcc_end
	length $I0, err
	if $I0, print_err
	goto start_curses

def_world:
	.sym Sub default
	newsub default, .Sub, _def_world
	.pcc_begin prototyped
	.arg sizef
	.arg size
	.arg COLLIDE
	.pcc_call default
retd:
	.result S15
	.pcc_end

start_curses:
	.sym Sub init_curses
	newsub init_curses, .Sub, _init_curses
	.pcc_begin prototyped
	.pcc_call init_curses
	.result STDSCR
	.pcc_end

	GEN_COUNT = 0

	.sym Sub dump
	newsub dump, .Sub, _dump

	.sym Sub generate
	newsub generate, .Sub, _generate
	.sym Sub check_key
	newsub check_key, .Sub, _check_key

loop:
	.pcc_begin prototyped
	.arg S15
	.arg SUPRESS_PRINT
	.arg x_offs
	.arg y_offs
	.arg size
	.arg GEN_COUNT
	.arg STDSCR
	.arg delay
	.pcc_call dump
	.pcc_end

         if GEN_COUNT >= MAX_GEN goto getout
	.pcc_begin prototyped
	.arg stop
	.arg x_offs
	.arg y_offs
	.arg delay
	.pcc_call check_key
ret:
	.result stop
	.result x_offs
	.result y_offs
	.result delay
	.pcc_end

	if stop != -2 goto not_one
	stop = -1
	goto gen_one
not_one:
        if stop < 0 goto no_gen
        if stop goto getout
gen_one:
	inc GEN_COUNT
	I31 = GEN_COUNT % 100
	if I31 goto skip
	printerr "."

skip:
	.pcc_begin prototyped
	.arg S15
	.arg size
	.arg stop
	.pcc_call generate
retk:
	.result S15
	.result stop
	.pcc_end
no_gen:
	branch loop

getout:
	P0 = CURS_SET
	I5 = 1
	invoke
	P0 = ENDWIN
	invoke
	time CUR_TIME
	TIME_DIFF = CUR_TIME - START_TIME

	# sleeping invalidates these data
	print "\n"
	print GEN_COUNT
	print " generations in "
	print TIME_DIFF
 	print " seconds. "
	GPS = GEN_COUNT / TIME_DIFF

	print GPS
	print " generations/sec\n"

	interpinfo I1, 1
	print "A total of "
	print I1
	print " bytes were allocated\n"

	interpinfo I1, 2
	print "A total of "
	print I1
	print " DOD runs were made\n"

	interpinfo I1, 3
	print "A total of "
	print I1
	print " collection runs were made\n"

	interpinfo I1, 10
	print "Copying a total of "
	print I1
	print " bytes\n"

	interpinfo I1, 5
	print "There are "
	print I1
	print " active Buffer structs\n"

	interpinfo I1, 7
	print "There are "
	print I1
	print " total Buffer structs\n"

	end

print_err:
	printerr "ERROR: "
	printerr err
	printerr "\n"
	exit 1
.end


# S15 has the incoming string, S0 is scratch
.pcc_sub _dump prototyped
        .param string world
	.param int SUPRESS_PRINT
	.param int x_offs
	.param int y_offs
	.param int size
	.param int GEN_COUNT
	.param pmc STDSCR
	.param int delay

	if SUPRESS_PRINT goto dumpend

	.local pmc WCLEAR
	.local pmc MVWADDSTR
	.local pmc MVWADDCH
	.local pmc WREFRESH

	WCLEAR     = global "ncurses::wclear"
	MVWADDSTR  = global "ncurses::mvwaddstr"
	MVWADDCH   = global "ncurses::mvwaddch"
	WREFRESH   = global "ncurses::wrefresh"

	.pcc_begin prototyped
	.arg STDSCR
	.nci_call WCLEAR
	.pcc_end

	.pcc_begin prototyped
	.arg STDSCR
	.arg 0
	.arg 0
	.arg "Generation: "
	.nci_call MVWADDSTR
	.pcc_end

	$S0 = GEN_COUNT
	.pcc_begin prototyped
	.arg STDSCR
	.arg 0
	.arg 13
	.arg $S0
	.nci_call MVWADDSTR
	.pcc_end

	$I0 = size * y_offs
	$I0 = $I0 + x_offs
	.local int CHARACTER_OFFSET
	CHARACTER_OFFSET = $I0
	.local int CHAR_POS
	CHAR_POS = 0
	.sym int total
	total = size * size
	.sym int cols
	.sym int rows
	.sym var ENV
	ENV = new Env
	$S0 = ENV["COLUMNS"]
	cols = $S0
	$S0 = ENV["LINES"]
	rows = $S0
	.local int X_COORD
	.local int Y_COORD

printloop:
        # TODO skip unprintable out of screen
	if CHARACTER_OFFSET >= total goto dumpend

	substr_r $S0, world, CHARACTER_OFFSET, 1
	if $S0 != "*" goto incit
	X_COORD = CHAR_POS % size
	if X_COORD > cols goto incit
	Y_COORD = CHAR_POS / size
	Y_COORD = Y_COORD + 2
	if Y_COORD > rows goto dumpend
	.pcc_begin prototyped
	.arg STDSCR
	.arg Y_COORD
	.arg X_COORD
	.arg 42				# Behold, the lowly star
	.nci_call MVWADDCH
	.pcc_end

incit:	inc CHARACTER_OFFSET
        inc CHAR_POS
	if  CHARACTER_OFFSET < total goto printloop

	.pcc_begin prototyped
	.arg STDSCR
	.nci_call WREFRESH
	.pcc_end

	if delay < 100 goto dumpend
	# as we gonna sleep here, lets burn some cycles to
	# check if usleep is available
	null $P0
	.sym pmc USLEEP
	dlfunc USLEEP, $P0, "usleep", "vi"
	$I0 = defined USLEEP
	if $I0 goto usleep
	sleep 1
	goto dumpend
usleep:
	.pcc_begin prototyped
	.arg delay
	.nci_call USLEEP
	.pcc_end
dumpend:
	.pcc_begin_return
	.pcc_end_return
.end

.pcc_sub _init_curses prototyped
	.local pmc INITSCR
	.local pmc START_COLOR
	.local pmc INIT_PAIR
	.local pmc COLOR_PAIR
	.local pmc WATTRON
	.local pmc CURS_SET
	.local pmc NODELAY
	.local pmc KEYPAD
	.local pmc STDSCR

	INITSCR     = global "ncurses::initscr"
	START_COLOR = global "ncurses::start_color"
	INIT_PAIR   = global "ncurses::init_pair"
	COLOR_PAIR  = global "ncurses::COLOR_PAIR"
	WATTRON     = global "ncurses::wattron"
	CURS_SET    = global "ncurses::curs_set"
	NODELAY     = global "ncurses::nodelay"
	KEYPAD      = global "ncurses::keypad"

	P0 = INITSCR
	invoke
	STDSCR = P5

	P0 = START_COLOR
	invoke

	P0 = INIT_PAIR
	I5 = 1		# Color pair 1
	I6 = 2 		# dark green fg
	I7 = 0		# Black background
	invoke

	P0 = COLOR_PAIR
	I5 = 1
	invoke

	# We pass what's returned from COLOR_PAIR straight on
	P0 = WATTRON
	invoke

	P0 = CURS_SET	# turn off cursor
	I5 = 0
	invoke

	P0 = NODELAY	# set nodelay mode
	P5 = STDSCR
	I5 = 1
	invoke

	P0 = KEYPAD	# set keypad mode
	P5 = STDSCR
	I5 = 1
	invoke
	.pcc_begin_return
	.return STDSCR
	.pcc_end_return
.end

# in: world (string)
#     size
# out new world
#     stop
.pcc_sub _generate prototyped
	.param string world
	.param int size
	.param int stop

	.sym int len
	.sym int pos
	.sym int count
	.sym int check	# pos in world
	.sym string new_world
	length len, world
	# allocate new world with all space
	repeat new_world, " ", len
	pos = 0
genloop:
	count = 0
NW:
	check = -size
	dec check
	check = check + len
	check = check + pos
	check = check % len
	# $S0 is always overwritten, so reuse it
	substr_r $S0, world, check, 1
	if $S0 != "*" goto North
	inc count
North:
	check = -size
	check = check + len
	check = check + pos
	check = check % len
	substr_r $S0, world, check, 1
	if $S0 != "*" goto NE
	inc count
NE:
	check = -size
	inc check
	check = check + len
	check = check + pos
	check = check % len
	substr_r $S0, world, check, 1
	if $S0 != "*" goto West
	inc count
West:
	check = -1
	check = check + len
	check = check + pos
	check = check % len
	substr_r $S0, world, check, 1
	if $S0 != "*" goto East
	inc count
East:
	check = 1
	check = check + len
	check = check + pos
	check = check % len
	substr_r $S0, world, check, 1
	if $S0 != "*" goto SW
	inc count
SW:
	check = size
	dec check
	check = check + len
	check = check + pos
	check = check % len
	substr_r $S0, world, check, 1
	if $S0 != "*" goto South
	inc count
South:
	check = size
	check = check + len
	check = check + pos
	check = check % len
	substr_r $S0, world, check, 1
	if $S0 != "*" goto SE
	inc count
SE:
	check = size
	inc check
	check = check + len
	check = check + pos
	check = check % len
	substr_r $S0, world, check, 1
	if $S0 != "*" goto checkl
	inc count
checkl:
	substr_r $S0, world, pos, 1
	if $S0 == "*" goto check_alive

# If eq 3, put a star in else a space
check_dead:
	if count == 3 goto star
	branch space

check_alive:
	if count < 2 goto space
	if count > 3 goto space
star:
	substr new_world, pos, 1, "*"
space:	# is space already
	inc pos
	if pos < len goto genloop
done:
	if  new_world != world goto dif
	   sleep 2
           stop = 1
dif:
	.pcc_begin_return
	.return new_world
	.return stop
	.pcc_end_return
.end

.pcc_sub _def_world prototyped
	.param int sizef
	.param int size
	.param int COLLIDE
	set S17,  "               "
	$I0 = sizef - 1
	unless $I0 goto nosize
	S16 = ""
	repeat S16, S17, $I0
nosize:

	set S0,  "               "
	set S1,  "               "
	set S2,  "               "
        set S3,  "               "
	set S4,  "  **           "
	set S5,  "*    *         "
	set S6,  "      *        "
	set S7,  "*     *        "
	set S8,  " ******        "
	set S9,  "               "
	set S10, "               "
	set S11, "               "
	if COLLIDE goto col
	set S12, "               "
	set S13, "               "
	set S14, "               "
	goto nocol
col:
	set S12, "             * "
	set S13, "              *"
 	set S14, "            ***"
nocol:
	.sym string world
	set world, ""
	concat world, S0
	concat world, S16
	concat world, S1
	concat world, S16
	concat world, S2
	concat world, S16
	concat world, S3
	concat world, S16
	concat world, S4
	concat world, S16
	concat world, S5
	concat world, S16
	concat world, S6
	concat world, S16
	concat world, S7
	concat world, S16
	concat world, S8
	concat world, S16
	concat world, S9
	concat world, S16
	concat world, S10
	concat world, S16
	concat world, S11
	concat world, S16
	concat world, S12
	concat world, S16
	concat world, S13
	concat world, S16
	concat world, S14
	concat world, S16
	$I1 = size * $I0
	repeat S16, S17, $I1
	concat world, S16
	.pcc_begin_return
	.return world
	.pcc_end_return
.end

.pcc_sub _load_file prototyped
	.param var argv
	.param int size

	.sym string world
	.sym string err
	world = ""
	.sym string file
	file = argv[1]
	err = "File not found " . file
	.sym var io
	open io, file, "<"
	$I0 = defined io
	unless $I0 goto nok
	null err
	.sym string line
	$I0 = size * size
	repeat world, " ", $I0
	.sym int pos
	$I0 = size / 2
	$I1 = $I0 * $I0
	pos = $I0 + $I1
	.sym int len
	.sym int format
	format = 0
	.const int PICTURE = 1
	.const int ABS     = 2
	.const int REL     = 3
	.sym   var points

loop:
	readline line, io
	length len, line
	unless len goto out
	$S0 = line[0]
	eq $S0, "#", check_format
	chopn line, 1		# \n
	dec len
	if format != PICTURE goto not_pic
	substr world, pos, len, line
	pos = pos + size
	goto loop
not_pic:
	if format != ABS goto not_abs
	goto do_rel
not_abs:
	if format != REL goto not_rel
do_rel:
	# parse \s(\d+) (\d+)
	# I really want PCRE or better inside Parrot :)
	.sym int s
	.sym int start
	.sym int in_digit
	in_digit = 0
	s = 0
get_d:
        if s >= len goto space
	$S0 = line[s]
	ord $I0, $S0
	if $I0 == 32 goto space
	if $I0 == 9  goto space
	if $I0 == 43 goto cont_d	# ignore +
	if $I0 == 45 goto dig		# sing, start dig
	if $I0 >= 0x30 goto dig1
	err = "Found junk at " . $S0
	goto out

dig1:
        if $I0 <= 0x39 goto dig
	err = "Found junk at " . $S0
	goto out

dig:	if in_digit == 1 goto cont_d
        if in_digit == 3 goto cont_d
	start = s
	inc in_digit

cont_d:
	inc s
	goto get_d
space:
        if in_digit == 0 goto cont_d
	if in_digit == 2 goto cont_d
	inc in_digit
	$I1 = s - start
	substr $S1, line, start, $I1
	$I2 = $S1
	push points, $I2
        if s >= len goto loop
	inc s
	goto get_d

end_d:
	goto loop

not_rel:
        err = "Unhandled file format"
	goto out

check_format:
	$S0 = line[1]
	if $S0 == "C" goto loop	# comment
	if $S0 == "#" goto loop	# comment
	if $S0 == "N" goto loop	# name of pattern
	if $S0 == "O" goto loop	# owner
	if $S0 == "U" goto loop	# use format
	unless format goto f1
	err = "Mixed formats found"
	goto out
f1:
	if $S0 != "P" goto not_P	# picture
	format = PICTURE
not_P:
	if $S0 != "A" goto not_A	# absolute
	format = ABS
	points = new PerlArray
not_A:
	if $S0 != "R" goto not_R	# relative
	format = REL
	points = new PerlArray
not_R:
	goto loop

out:
	close io
	if format == PICTURE goto done
	# we have an array of x,y pairs now
	# find min, max
	.sym int min_x
	.sym int min_y
	.sym int max_x
	.sym int max_y
	min_x = 99999
	min_y = 99999
	max_x = -99999
	max_y = -99999
	.sym int x
	.sym int y
	.sym int len
	len = points
	s = 0
lp:
	x = points[s]
	inc s
	y = points[s]
	inc s
	if x >= min_x goto no_min_x
	min_x = x
no_min_x:
	if x <= max_x goto no_max_x
	max_x = x
no_max_x:
	if y >= min_y goto no_min_y
	min_y = y
no_min_y:
	if y <= max_y goto no_max_y
	max_y = y
no_max_y:
	if s < len goto lp

#	printerr min_x
#	printerr ", "
#	printerr min_y
#	printerr ", "
#	printerr max_x
#	printerr ", "
#	printerr max_y
#	printerr "\n\n"

	# now fill world
	s = 0
lp2:
	x = points[s]
	inc s
	y = points[s]
	inc s
	x = x - min_x
	y = y - min_y
#	printerr x
#	printerr ", "
#	printerr y
#	printerr "\n"
	.sym int c
	c = y * size
	c = x + c
	# TODO abs/rel and bounds checking
	world[c] = "*"
	if s < len goto lp2
done:
nok:
	.pcc_begin_return
	.return world
	.return err
	.pcc_end_return
.end

.pcc_sub _check_key prototyped
	.param int stop
	.param int x_offs
	.param int y_offs
	.param int delay

	.sym int key
	.sym pmc GETCH
	pushi
	GETCH = global "ncurses::getch"
	invoke GETCH
	save I5
	popi
	restore key
	if key == KEY_LEFT goto is_4
	if key == KEY_RIGHT goto is_6
	if key == KEY_UP goto is_8
	if key == KEY_DOWN goto is_2
	if key == KEY_HOME goto is_5
	if key != 113 goto no_q
	stop = 1
no_q:
	if key != 81 goto no_Q
	stop = 1
	goto key_done
no_Q:
	if key != 0x38 goto no_8
is_8:
	y_offs = y_offs + 10
	goto key_done
no_8:
	if key != 0x32 goto no_2
is_2:
	if y_offs < 10 goto key_done
	y_offs = y_offs - 10
	goto key_done
no_2:
	if key != 0x34 goto no_4
is_4:
	x_offs = x_offs + 10
	goto key_done
no_4:
	if key != 0x36 goto no_6
is_6:
	if x_offs < 10 goto key_done
	x_offs = x_offs - 10
	goto key_done
no_6:
	if key != 0x35 goto no_5
is_5:
	x_offs = 0
	y_offs = 0
	goto key_done
no_5:
	if key != 103 goto no_g
	if stop == 0 goto g0
	stop = 0
	goto key_done
g0:
	stop = -1
	goto key_done
no_g:
	if key != 111 goto no_o
	stop = -2
	goto key_done
no_o:
	if key != 115 goto no_s
	stop = 0
	delay = delay * 2
	goto key_done
no_s:
	if key != 102 goto no_f
	stop = 0
	delay = delay / 2
	if delay goto key_done
	delay = 1
	goto key_done
no_f:

key_done:
	.pcc_begin_return
	.return stop
	.return x_offs
	.return y_offs
	.return delay
	.pcc_end_return
.end
=head1 NAME

ncurses_life - Play conway's (no, not *him*. The other conway) game
of life

=head1 SYNOPSIS

  parrot examples/assembly/ncurses_life.imc examples/assembly/acorn.l

  parrot examples/assembly/ncurses_life.imc

=head1 COMMANDS

=over 4

=item B<q>, B<Q>

Quit.

=item B<8>, B<2>, B<UP>, B<DOWN>

Move world up or down.

=item B<4>, B<6>, B<LEFT>, B<RIGHT>

Move world left or right

=item B<5>, B<HOME>

Center world.

=item B<g>

Toggle running the game.

=item B<o>

Single step one generation.

=item B<s>

Run slower.

=item B<f>

Run faster.

=back

=cut
