diff options
Diffstat (limited to 'ipl/gpacks/xtiles/xtiles.icn')
| -rw-r--r-- | ipl/gpacks/xtiles/xtiles.icn | 881 |
1 files changed, 881 insertions, 0 deletions
diff --git a/ipl/gpacks/xtiles/xtiles.icn b/ipl/gpacks/xtiles/xtiles.icn new file mode 100644 index 0000000..ed43b80 --- /dev/null +++ b/ipl/gpacks/xtiles/xtiles.icn @@ -0,0 +1,881 @@ +# tiles.icn + +# tiles puzzle + +# $Id: X-Tiles.icn,v 3.9 1997/02/21 11:35:38 espie Exp espie $ +# minor mods 2000/12/23 gmt + +link graphics + + +$define SMILEY_SIZE 40 + +$define DEFAULT_TSIZE 35 +$define MIN_TSIZE 10 +$define MAX_TSIZE 100 +$define MINSIZE 256 + +# we use globals as this is mostly a hack + + + +# individual tiles size (in pixels) + +global tile_width, tile_height + + + + +# total playfield size +global n, m + + + + + +global tiles_win, tiles_bw_win # graphics context used to draw tiles + + +# tiles can be shown as normal, highlighted or shadowed border, +# or even patterned b&w if /normal +record color_set(normal, highlight, shadow, pattern, name) + + + + +global colors # color array to map tiles colors +global black, white, bgcolor + + +global smiley1, smiley2, smiley3 # smiley images in the lower-right corner + +global bgimage # image to put in as background + + + + +################################################################# +# +# graphics rendering +# +################################################################# + +# replaces background with my own Image +procedure my_erase_area(win, x, y, w, h) + /x := 0 + /y := 0 + /w := WAttrib(win, "width") - x + /h := WAttrib(win, "height") - y + CopyArea(bgimage, win, x, y, w, h, x, y) +end + +procedure my_draw_string(win, x, y, s) + Fg(white) + DrawString(win, x+1, y+1, s) + Fg(black) + DrawString(win, x, y, s) +end + + +procedure write_score(score) + Fg(black) + # erase old score, that means the lower band of the window + # except the SMILEY_SIZE x SMILEY_SIZE lower-right smiley + EraseArea(&window, 0, m * tile_height, + n * tile_width-SMILEY_SIZE, SMILEY_SIZE) + my_draw_string(&window, 10, m * tile_height + 15, score) +end + + +procedure draw_smiley(image) + DrawImage(&window, n * tile_width-SMILEY_SIZE, m*tile_height, + SMILEY_SIZE||",c1,"||image) +end + + +# ask the user if he wants to replay, new, quit +procedure user_entry() + static buttons + initial + { + buttons := ["(r)eplay ", "(n)ew ", "(q)uit "] + } + + # write the button and record corresponding areas + leading := WAttrib("ascent") + 5 + s1 := TextWidth(buttons[1]) + s2 := TextWidth(buttons[2]) + s3 := TextWidth(buttons[3]) + my_draw_string(&window, 5, leading, buttons[1]||buttons[2]||buttons[3]) + repeat + { + e := Event() + case e of + { + &lrelease | &mrelease | &rrelease: + { + # hardcoded button area check + if 0 <= &y <= WAttrib("fheight") + 10 then + { + if (5 <= &x < 5 + s1) then return "r" + if (5 + s1 <= &x < 5 + s1 + s2) then return "n" + if (5 + s1 + s2 <= &x < 5 + s1 + s2 + s3) then return "q" + } + if (WAttrib("height")-SMILEY_SIZE < &y < WAttrib("height") & + WAttrib("width")-SMILEY_SIZE < &x < WAttrib("width")) then + return "u" + } + "q"|"n"|"r"|"u": + { + return e + } + } + } +end + + +# setup tiles color mapping +procedure setup_colors(color_mode) + + # setup color mode correctly + if WAttrib("depth") = 1 then + insert(color_mode, "bw") + every member(color_mode, "bw") & + member(color_mode, m <- "pastel"|"reduced"|"lighter"|"darker") do + write("Warning: "||m||" makes no sense in black and white mode") + if member(color_mode, "darker") & member(color_mode, "lighter") then + write("Warning: lighter and darker specified both, uses darker") + # establish possible set of colors/patterns + color_names := set([ + ["red", "darkgray"], + ["green", "gray"], + ["blue", "lightgray"], + ["yellow", "vertical"], + ["grey", "diagonal"], + ["purple", "horizontal"], + ["orange", "grid"], + ["magenta", "trellis"], + ["cyan", "checkers"], + ["blue-cyan", "grains"], + ["brown", "scales"], + ["bluish green", "waves"] + ]) + + colors := [] + # create randomized mapping + if member(color_mode, "pastel") then saturation := "moderate " + else saturation := "" + lightness := ["pale", "light ", "medium ", "dark ", "deep "] + if member(color_mode, "darker") then + correction := 1 + else if member(color_mode, "lighter") then + correction := -1 + else + correction := 0 + while c := ?color_names do + { + delete(color_names, c) + put(colors, color_set(&null, white, black, c[2], saturation||c[1]) ) + member(color_mode, "bw") | + { + colors[-1].normal := + ColorValue(lightness[3+correction]||colors[-1].name) + } + } + member(color_mode, "bw" | "reduced") | + every c := !colors do + { + c.highlight := \ColorValue(lightness[2+correction]||\c.name) | white + c.shadow := \ColorValue(lightness[4+correction]||\c.name) | black + } + return ColorValue(lightness[3+correction]||"gray") +end + +procedure setup_graphics(color_mode) + + if /bgimage then dummy := WOpen("canvas=hidden", "width=1", "height=1") + # assume the background image first pixel is background + if /&window then + stop("Error: could not open window. Check your display/xauth.") + bgcolor := ColorValue(Pixel(\bgimage)) + black := ColorValue("black") | stop() + white := ColorValue("white") | stop() + if \bgcolor == black then black :=: white + # These sizes MUST be real to match the background image size + tile_width := (MINSIZE < WAttrib(\bgimage, "width"))/real(n) | + DEFAULT_TSIZE + tile_height := + ((MINSIZE < WAttrib(\bgimage, "height"))+SMILEY_SIZE)/real(m) | + DEFAULT_TSIZE + tile_width >:= MAX_TSIZE + tile_height >:= MAX_TSIZE + + # compute and adjust window width/tiles width + dwidth := WAttrib(&window, "displaywidth") + if dwidth < n * tile_width then + # leave one tile margin + tile_width := dwidth / (n+1) + + # compute and adjust window height/tiles height + dheight := WAttrib(&window, "displayheight") + if dheight < m * tile_height + SMILEY_SIZE then + # leave one tile margin + tile_height := (dheight - SMILEY_SIZE) / (m+1) + + tile_width <:= MIN_TSIZE + tile_height <:= MIN_TSIZE + + width := n * tile_width + height := m * tile_height + SMILEY_SIZE + + tile_width := integer(tile_width) + tile_height := integer(tile_height) + + &window := WOpen("label=the X-Tiles", + "bg="||(\bgcolor|white), + "font=sans,bold,proportional", + "width="||width, "height="||height) + + WClose(\dummy) + if bsize := MINSIZE > WAttrib(\bgimage, "width") then + { + WAttrib(bgimage, "width="||width) + every dest := bsize to width by bsize do + CopyArea(bgimage, bgimage, 0, 0, bsize, &null, dest, 0) + } + if bsize := MINSIZE > WAttrib(\bgimage, "height") then + { + WAttrib(bgimage, "height="||height - SMILEY_SIZE) + every dest := bsize to height by bsize do + CopyArea(bgimage, bgimage, 0, 0, &null, bsize, 0, dest) + } + + tiles_bw_win := Clone(&window, "fillstyle=textured", + "fg="||white,"bg="||black) + newbg := setup_colors(color_mode) + /bgcolor := newbg + Bg(bgcolor) + EraseArea(&window) + tiles_win := Clone(&window) + + smiley1 := +$include "smiley1.icn" + smiley2 := +$include "smiley2.icn" + smiley3 := +$include "smiley3.icn" +end + + +################################################################# +# +# tiles and tiles rendering +# +################################################################# + + + +# Tiles are saved in a 2-dimensional array +# Each tile is a unique individual (useful for set entries) +# that records its own position column/line as well as color +# /color for empty tiles + + +record tile_square(column, line, color, connect) + +procedure t(i, j) + static h, empty + initial + { + h := list(n) + every h[1 to n] := list(m) + every a := 1 to n do + every b := 1 to m do + h[a][b] := tile_square(a, b, &null) + empty := tile_square() + } + if (1 <= i <= n) & (1 <= j <= m) then + return h[i][j] + else + return empty +end + + +# compute the connectivity of a given tile (north, south, east, west) +# suspends with neighboring tiles whose connectivity may have changed +# PLEASE NOTE: compute_connectivity is definitily NOT purely functional +# For the computation to be correct, the generator MUST suspends ALL its +# results +procedure compute_connectivity(p) + /p.connect := '' + "ewsn" ? + { + every q := neighbor(p) do + { + if \p.color = \q.color | (/p.color & /q.color) then + { + if not any(p.connect) then + { + p.connect ++:= move(1) + suspend q + } + else + move(1) + } + else + { + if any(p.connect) then + { + p.connect --:= move(1) + suspend q + } + else + move(1) + } + } + } +end + + +# draw bevel around a tile, recessed if /bevel +procedure draw_bevel(tile, bevel) + if /tile.color then fail + x := (tile.column - 1) * tile_width + y := (m - tile.line) * tile_height + x1 := x + tile_width - 1 + y1 := y + tile_height - 1 + c1 := colors[tile.color].highlight + c2 := colors[tile.color].shadow + if \bevel then + c1 :=: c2 + + # draw bevel areas only if the corresponding connectivity does + # NOT exist + Fg(c1) + "n" ? any(tile.connect) | + DrawRectangle(x, y, tile_width-1, 1) + "e" ? any(tile.connect) | + DrawRectangle(x, y, 1, tile_height-1) + Fg(c2) + "s" ? any(tile.connect) | + DrawRectangle(x, y1-1, tile_width-1, 1) + "w" ? any(tile.connect) | + DrawRectangle(x1-1, y, 1, tile_height-1) +end + + +# draw tile itself, including bevel +procedure draw_tile(tile, bevel) + x := (\tile.column - 1) * tile_width | fail + y := (m - tile.line) * tile_height + if /tile.color then + { + EraseArea(&window, x, y, tile_width, tile_height) + } + else + { + if Fg(tiles_win, \colors[tile.color].normal) then + FillRectangle(tiles_win, x, y, tile_width, tile_height) + else + { + WAttrib(tiles_bw_win, + "pattern="||colors[tile.color].pattern)|stop(colors[tile.color].pattern) + FillRectangle(tiles_bw_win, x, y, tile_width, tile_height) + } + draw_bevel(tile, bevel) + } + return +end + + +procedure draw_bevel_set(s, bevel) + if *s <= 1 then fail + every draw_bevel(!s, bevel) +end + +################################################################# +# +# the game +# +################################################################# + + +# suspend a tile's neighbors + +procedure neighbor(p) + suspend t(\p.column - 1 | \p.column + 1, p.line) | + t(\p.column, p.line - 1 | p.line + 1) +end + +# suspend a tile's upwards neighbors, enough for checking that moves remain +procedure up_neighbor(p) + suspend t(p.column + 1, p.line) | t(p.column, p.line + 1) +end + + + +# Ye old connected component algorithm +# start at t(i, j) and maps connected component. +# return &null if set is empty, +# and the old set if it is the same set + +procedure connected_set(old, i, j) + p := t(i, j) + if member(\old, p) then return old + c := \p.color | return &null + s := set() + l := [p] + while p := pop(l) do + if not member(s, p) then + { + insert(s, p) + every q := neighbor(p) & \q.color = c do + put(l, q) + } + return s +end + + +# suspends all current columns. Assumes a stable game, stops +# at first empty column +procedure columns() + every i := seq() do + { + if /t(i, 1).color then fail + suspend i + } +end + +# suspend all current lines for column c. Stops at first empty line +# Note that the game is always stable: the first empty tile means the +# top of the column +procedure lines(c) + every j := seq() do + { + if /t(c, j).color then fail + suspend j + } +end + +procedure used_tiles() + suspend t(c := columns(), lines(c)) +end + +# check whether you can still play +procedure remains_move() + every p := used_tiles() do + if \p.color = \up_neighbor(p).color then return + fail +end + + +# compute the interval of columns spanned by a set +# Note that all columns must be present as the set if 4-connected +procedure columns_of_set(s) + local cmin, cmax + + # you can check that the following test does indeed set up cmin + # and cmax correctly + every c := (!s).column do + (/cmin := c & /cmax := c) | (cmin >:= c) | (cmax <:= c) + return [cmin, cmax] +end + + +# make tiles fall down in individual columns +procedure remove_individual_tiles(remember, saved, to_draw, s, cmin, cmax) + # for each involved column + every col := cmin to cmax do + { + # j: tile line # to replace, k: tile line # to replace it with + # find the lowest removable tile + if member(s, t(col, j := lines(col))) then + { + k := j + # as long as we did not get outside + while \t(col, j).color do + { + # find non erased tile + k +:= 1 + while member(s, t(col, k)) do + k +:= 1 + + # and replace it + p := t(col, j) + put(remember, copy(p)) + insert(saved, p) + put(to_draw, p) + p.color := t(col, k).color + j +:= 1 + } + } + } +end + +# remove empty columns +procedure remove_columns(remember, saved, to_draw, cmin, cmax) + # now check for empty columns in known range + if /t(col := cmin to cmax, 1).color then + { + # if we did find one, we have to check all columns + colp := col + while col <= n do + { + colp +:= 1 + # skip over empty columns... well stop when you get outside + while /t(colp, 1).color & colp <= cmax do + colp +:= 1 + + # copy one column: do every line + every j := seq() do + { + p := t(col, j) + q := t(colp, j) + # stop when BOTH columns (src and dest) are empty + if /p.color & /q.color then break + member(saved, p) | + { + put(remember, copy(p)) + insert(saved, p) + put(to_draw, p) + } + p.color := q.color + } + col +:= 1 + } + } + +end + +procedure remove_tiles(s) + cols := columns_of_set(s) + + # first we move tiles around + backtrack := [] # copy of tiles that where changed + to_draw := [] # list of tiles to draw + saved := set() # tiles that changed + # note that to_draw and saved hold the same tiles. + # saved is used for membership, and to_draw to display tiles + # in linear order, which is less confusing + remove_individual_tiles(backtrack, saved, to_draw, s, cols[1], cols[2]) + remove_columns(backtrack, saved, to_draw, cols[1], cols[2]) + + # then we update needed connectivities + other := rebuild_connectivity(saved) + # and finally we redraw tiles + redraw_tiles(to_draw, other) + return backtrack +end + + +# redraw the list in order, followed by the set. +procedure redraw_tiles(l, s) + every p := !l do + { + # there may be duplicates + delete(s, p) + draw_tile(p) + } + every draw_tile(!s) +end + + +# rebuild the connectivity of the whole game, knowing the set of tiles +# that changed colors +procedure rebuild_connectivity(s) + changed := set() + neigh := set() + + # for each tile of the set + every p := !s do + { + q := &null + # recompute its connectivity and mark its neighbors that have + # changed + every q := compute_connectivity(p) do + member(s, q) | insert(neigh, q) + + # connectivity changed iff there was such a neighbor ! + if \q then + insert(changed, p) + } + + # neighbors are simpler, as we just have to update their connectivity + # watch out ! we have to use ALL the results of the generator + # compute_connectivity for the computation to be correct + every compute_connectivity(!neigh) + changed ++:= neigh + return changed +end + +procedure undo(changes) + c := set() + l := [] + + # backtrack changes, remember what to draw + every p := !changes do + { + q := t(p.column, p.line) + q.color := p.color + # easier to build BOTH the list (for non confusing redraw) + # and the set (needed by rebuild_connectivity) + insert(c, q) + put(l, q) + } + other := rebuild_connectivity(c) + redraw_tiles(l, other) +end + +procedure usage() + return "Usage: X-Tiles [-v] [-h] _ +[-bw] [-pastel] [-reduced] [-darker] [-lighter] _ +[colors] [columns] [lines] [seed] [bg]" +end + + +procedure whoami() +# $Id: X-Tiles.icn,v 3.9 1997/02/21 11:35:38 espie Exp espie $ + name := "" + "$Id: X-Tiles.icn,v 3.9 1997/02/21 11:35:38 espie Exp espie $" ? + { + ="$Id: " + name ||:= tab(find(".icn,v")) + =".icn,v " + name ||:= " version "||tab(upto(' '))||move(1)||tab(upto(' ')) + } + return name||" by Marc Espie (Marc.Espie@ens.fr)" +end + + +procedure new_game(r) + + # build a playable game + repeat + { + every t(1 to n, 1 to m).color := ?r + if remains_move() then + break + } + + every compute_connectivity(t(1 to n, 1 to m)) + + # draw initial setup + EraseArea(&window) + draw_smiley(smiley1) + every draw_tile(used_tiles()) + + + # remove left over events from last game + while *Pending() > 0 do + Event() +end + + +procedure adjust_end_score() + # adjust end score + count := 0 + every used_tiles() do + count +:= 1 + if count > 0 then + { + draw_smiley(smiley2) + return -count + } + else + { + draw_smiley(smiley3) + return 1000 + } +end + + + +procedure main(L) + parms := [] + color_mode := set() + + # process all options + every p := !L do + map(p) ? + { + {=("-bw"|"-reduced"|"-pastel"|"-lighter"|"-darker") & pos(0) & insert(color_mode, tab(2)) }| + {=("-help"|"-h") & pos(0) & stop(usage())} | + {=("-v"|"-version") & pos(0) & stop(whoami())} | + {i := integer(tab(0)) & put(parms, i)} | + {any('-') & stop("Unknown option "||tab(0)||"\n"||usage())} | + # if we have a background image + {bgimage := WOpen("canvas=hidden", "image="||p, "gamma=1.0") & + # use our own flavour of EraseArea + EraseArea := my_erase_area} | + {stop("Can't load background image "||tab(0))} + + } + + + r := get(parms) | 4 + n := get(parms) | 10 + m := get(parms) | n + last_random := get(parms) | map(&clock, ':', '9') + r <:= 2 + n <:= 4 + n >:= 40 + m <:= 4 + m >:= 40 + &random := map(&clock, ':', '9') + + # we have the game size and the background image, + # so we can open the window + setup_graphics(color_mode) + r >:= *colors + &random := last_random + + while not (\last == "q") do + { + # setup for new game or replay + if \last == "r" then + { + /best_score := \score + &random := last_random + } + else + { + last_random := &random + best_score := &null + } + writes("Playing tiles ", r, " ", n, " ", m, " ", + left(&random, 12)) + + new_game(r) + lasti := &null + s := &null + changes := [] + log := [] + score := 0 + write_score(score) + + repeat + { + # either get pending event, or busy-peek the mouse pointer position + if *Pending() > 0 then + { + e := Event() + i := &x/tile_width+1 + j := m - &y/tile_height + } + else + { + e := &null + i := WAttrib("pointerx")/tile_width+1 + j := m - WAttrib("pointery")/tile_height + } + + # check whether tile position changed + if (i = \lasti) & (j = \lastj) then + { + # if busy-peeking, add suitable delay + if /e then delay(50) + } + else + { + lasti := i + lastj := j + # build new connected set + sp := connected_set(s, i, j) + + # if a new set + if sp ~=== s then + { + # un highlight old set (if needed) + draw_bevel_set(\s) + s := sp + # highlight new set + draw_bevel_set(\s, 1) + if *\s > 2 then + write_score(score||" (+"||(*s-2)*(*s-2)||")") + else + write_score(score) + } + } + + if e === "c" then + { + setup_colors(color_mode) + if *\s < 2 then s := &null + every p := used_tiles() do + draw_tile(p, member(\s, p) | &null) + } + + # check whether actually zapping + if e === (&lrelease | &mrelease | &rrelease) & *\s >= 2 then + { + push(changes, [score, remove_tiles(s)]) + put(log, [i, j]) + # adjust score + score +:= (*s-2)*(*s-2) + write_score(score) + + # setup `virgin' highlighted set/position + lasti := &null + s := &null + e := &null + + # check for end + if not remains_move() then + { + score +:= adjust_end_score() + if \best_score <:= score then + { + prompt := "Best " + best_log := log + } + else + prompt := "End " + + write_score(prompt||score) + write(" Final score ", score) + last := user_entry() + if last == "u" then + { + EraseArea(0, 0, &null, WAttrib("leading")+10) + to_undo := pop(changes) + score := to_undo[1] + write_score(score) + draw_smiley(smiley1) + undo(to_undo[2]) + } + else + break + } + } + if ( + (e === (&lrelease | &mrelease | &rrelease) & + WAttrib("height")-SMILEY_SIZE < &y < WAttrib("height") & + WAttrib("width")-SMILEY_SIZE < &x < WAttrib("width")) | + e === "u" + ) & *changes > 0 then + { + draw_bevel_set(\s) + s := &null + lasti := &null + to_undo := pop(changes) + score := to_undo[1] + write_score(score) + undo(to_undo[2]) + } + # check if user wants to quit prematurely + if e === "q" then + { + write_score("Sure ?") + e := Event() + if (e == ("o" | "y" | "q")) then + { + last := "q" + write() + break + } + else + write_score(score) + } + } + } +end |