diff options
Diffstat (limited to 'ipl/gprogs')
| -rw-r--r-- | ipl/gprogs/breakout.icn | 24 | ||||
| -rw-r--r-- | ipl/gprogs/gallery.icn | 29 | ||||
| -rw-r--r-- | ipl/gprogs/kaleid.icn | 3 | ||||
| -rw-r--r-- | ipl/gprogs/spider.icn | 104 | ||||
| -rw-r--r-- | ipl/gprogs/trkvu.icn | 58 | ||||
| -rw-r--r-- | ipl/gprogs/tron.icn | 191 |
6 files changed, 361 insertions, 48 deletions
diff --git a/ipl/gprogs/breakout.icn b/ipl/gprogs/breakout.icn index 28559f1..56b0551 100644 --- a/ipl/gprogs/breakout.icn +++ b/ipl/gprogs/breakout.icn @@ -6,7 +6,7 @@ # # Author: Nathan J. Ranks # -# Date: September 3, 2000 +# Date: November 22, 2009 # ############################################################################ # @@ -49,13 +49,21 @@ procedure main() WOpen("size=293,320") | stop("can't open window") - sphere := "3,g16,~0~_ - 000_ - ~0~" #black sphere - - blank := "3,g16,~F~_ - FFF_ - ~F~" #white sphere to erase + sphere := "7,g16,~~000~~_ + ~00000~_ + 0000000_ + 0000000_ + 0000000_ + ~00000~_ + ~~000~~" #black sphere + + blank := "7,g16,~~FFF~~_ + ~FFFFF~_ + FFFFFFF_ + FFFFFFF_ + FFFFFFF_ + ~FFFFF~_ + ~~FFF~~" #white sphere to erase level := 1 #default start level create_blocks() #as the name suggests diff --git a/ipl/gprogs/gallery.icn b/ipl/gprogs/gallery.icn index 4dcd0a7..2379f99 100644 --- a/ipl/gprogs/gallery.icn +++ b/ipl/gprogs/gallery.icn @@ -6,7 +6,7 @@ # # Author: Gregg M. Townsend # -# Date: August 3, 2005 +# Date: May 27, 2008 # ############################################################################ # @@ -35,11 +35,10 @@ # The right mouse button activates the same popup momentarily until # the button is released. # -# -wnnn sets the maximum width for displaying an image; -# -hnnn sets the maximum height. -snnn sets both. -# By default, sizes are chosen automatically, subject to a minimum -# size of 32x32, to allow all images to fit in a single window. -# +# -wnnn sets the minimum thumbnail width. The default is 32. +# -hnnn sets the minimum thumbnail height. The default is 32. +# -snnn sets the minimum height and width together. +# # -r arranges images in rows instead of columns. # -m maximizes the window size before displaying images. # -t trims file names of leading path components and extensions. @@ -124,13 +123,11 @@ procedure main(args) else fh := WAttrib("fheight") fw := WAttrib("fwidth") - maxw := \opts["w"] | \opts["s"] | 2 * \opts["h"] - maxh := \opts["h"] | \opts["s"] | 2 * \opts["w"] - - # If no image size specified, try to guess to fill the window - if /maxw then - layout(*args) + # Determine thumbnail sizes. + layout(*args) + maxw <:= \opts["w"] | \opts["s"] | 2 * \opts["h"] + maxh <:= \opts["h"] | \opts["s"] | 2 * \opts["w"] aspmax := real(maxw) / real(maxh) # Display the files. @@ -149,7 +146,7 @@ procedure main(args) return # Get the next file and translate its image. - f := open(fname) | + f := open(fname, "ru") | { write(&errout, fname, ": can't open"); next } # Read the image, full sized, into a scratch canvas @@ -345,7 +342,7 @@ end procedure popinfo(a, e, w, h) local f, i, n, x, y - f := open(a.fname) + f := open(a.fname, "ru") seek(f, 0) n := where(f) seek(f, 1) @@ -445,7 +442,7 @@ procedure mkgif(cmd, fname) if \opts["d"] then write(&errout, "+ ", cmd) system(cmd) - f := open(tempname) | fail + f := open(tempname, "ru") | fail win := load(tempname) close(f) remove(tempname) @@ -486,7 +483,7 @@ procedure jsize(irec, fname) local s, p, line, w, h s := "" - p := open("rdjpgcom -verbose " || fname, "p") | fail + p := open("rdjpgcom -verbose \"" || fname || "\"", "p") | fail while line := read(p) do line ? { ="JPEG image is " | next w := tab(many(&digits)) | next diff --git a/ipl/gprogs/kaleid.icn b/ipl/gprogs/kaleid.icn index 11b3ed9..cfb825d 100644 --- a/ipl/gprogs/kaleid.icn +++ b/ipl/gprogs/kaleid.icn @@ -6,7 +6,7 @@ # # Author: Stephen B. Wampler # -# Date: May 2, 2001 +# Date: November 22, 2009 # ############################################################################ # @@ -218,6 +218,7 @@ local radius, xoff, yoff # draw it in kaleidoscopic form draw_circle(mid_win-yoff, mid_win+xoff, radius) draw_circle(mid_win-yoff, mid_win-xoff, radius) + WDelay(10) return end diff --git a/ipl/gprogs/spider.icn b/ipl/gprogs/spider.icn index 0c25529..10ed22a 100644 --- a/ipl/gprogs/spider.icn +++ b/ipl/gprogs/spider.icn @@ -6,7 +6,9 @@ # # Author: William S. Evans # -# Date: February 19, 2002 +# Contributor: Gregg M. Townsend +# +# Date: September 6, 2009 # ############################################################################ # @@ -45,6 +47,11 @@ # 's' Save the current game to a file. # 'r' Read a game from a file. # '1234567890' Move run from indicated pile. +# 'bfhptvwxyz' Move run from indicated pile. +# +# If $HOME/.spdhist exists and is writable at the start of the run, a +# single history record is written to it for each 'n' or 'q' or 'r' +# command, unless no cards have been moved. # ############################################################################ # @@ -52,15 +59,20 @@ # ############################################################################ # -# Links: drawcard, graphics, random +# Links: datetime, drawcard, graphics, random # ############################################################################ +link datetime link drawcard link graphics link random $define SPIDER_VERSION "spider-0.3" # version of spider +$define HISTORY_FILE ".spdhist" # name of history file in $HOME + +$define NUM_LABELS "1234567890" # numeric column labels +$define LTR_LABELS "bfhptvwxyz" # alphabetic column labels global cardw, cardh # card width and height global ymargin, xmargin, xgap # margins, gap between cards @@ -74,6 +86,8 @@ global nextCard # an integer global undoStack # list of integers global currentFile # filename to store/retrieve a game global readingGame # =1 if reading game from file =0 o.w. +global startTime # start time of this game +global histfile # appendable history file, if any, else null procedure main(args) local fromPile,maxCards,e,p @@ -82,6 +96,7 @@ procedure main(args) newgame() repeat case e := Event() of { !"qQ": { + report() exit() } "d": { @@ -94,26 +109,29 @@ procedure main(args) message(hiddenNames(1+(&x-xmargin+xgap/2)/(cardw+xgap))) } "n": { + report() newgame() } "u": { undo() | beep() } "r": { + report() readingGame := 1 WAttrib("bg=pale gray","fg=black") readFile() readingGame := 0 WAttrib("bg=deep moderate green","fg=white") drawBoard() + startTime := &null # unknown original start time } "s": { WAttrib("bg=pale gray","fg=black") saveFile() WAttrib("bg=deep moderate green","fg=white") } - !"1234567890": { - p := 0 < ord(e)-ord("0") | 10 + !(NUM_LABELS | LTR_LABELS): { + p := find(e, NUM_LABELS | LTR_LABELS) click(13,p,p) | beep() } &lpress | &rpress: { @@ -138,6 +156,7 @@ procedure main(args) end procedure initialize(args) + local hfname currentFile := "game1.spd" readingGame := 0 @@ -171,6 +190,10 @@ procedure initialize(args) ymargin <:= fheight + hfname := (getenv("HOME") | "?noHOME?") || "/" || HISTORY_FILE + if close(open(hfname)) then # if file already exists + histfile := open(hfname, "wa") # may fail leaving null if not writable + return end @@ -205,12 +228,19 @@ procedure newgame(initialDeck) up[11] := 0 drawBoard() + + startTime := &clock return end procedure drawPiles(p[]) local i,j,n,x,y,ht,mlap,upstart,yposns + if *pile[11] = 104 then { + drawWin() + return + } + if readingGame = 0 then { every i := 1 <= 10 >= !p do { @@ -219,8 +249,8 @@ procedure drawPiles(p[]) yoff[i] := yposns := list(0) x := xmargin + (i-1) * (cardw + xgap) EraseArea(x,ymargin,cardw,height-2*ymargin) - GotoXY(x+cardw/2,ymargin-descent) - WWrites(10 > i | 0) + GotoXY(x+cardw/2-10,ymargin-descent) + WWrites(LTR_LABELS[i], " ", NUM_LABELS[i]) n := *(pile[i]) mlap := lap if n > 1 then @@ -247,9 +277,28 @@ procedure drawPiles(p[]) return end +procedure drawWin() + local i, j, s, x, y, suits + + EraseArea() + suits := [ + "MLKJIHGFEDCBA", "mlkjihgfedcba", "zyxwvutsrqpon", "ZYXWVUTSRQPON" ] + every i := 1 to 4 do { + s := suits[i] + y := 125 * (i - 1) + every x := 20 | 400 do { + every j := 1 to 13 do { + drawcard(x + 24 * j, y, s[j]) + WDelay(5) + } + } + } + return +end procedure drawBoard() if readingGame = 0 then { + EraseArea() WAttrib("label=Spider Deck "||104-nextCard+1) drawPiles(1,2,3,4,5,6,7,8,9,10) } @@ -424,8 +473,8 @@ procedure succ(c) end procedure beep() - writes("\^g") - flush(&output) + writes(&errout, "\^g") + flush(&errout) return end @@ -505,6 +554,7 @@ procedure saveFile() write(output,deck) every writes(output,!undoStack," ") write(output,"") + close(output) return } else { Notice("Cannot open file for writing.") @@ -565,3 +615,41 @@ procedure doAll() } return end + +procedure report() + local i, u, s, stopTime, elapsed, nmoves, undealt, cardsleft + + if *undoStack = 0 then return # don't report if no moves made + + stopTime := &clock + elapsed := ClockToSec(stopTime,0) - (ClockToSec(\startTime,0)|-1) + if elapsed < 0 then # if wraparound crossing midnight + elapsed +:= 24 * 60 * 60 + elapsed >:= 9999 # 9999 sec means unknown or bogus time + + nmoves := *undoStack/3 + undealt := 104 - nextCard + 1 + cardsleft := 0 + every cardsleft +:= *pile[1 to 10] + write(nmoves, " moves in ", elapsed, " seconds, leaving ", + cardsleft + undealt, " cards") + + if /histfile then return # if no history file, nothing more to do + + writes(histfile, &date, " ", stopTime[1+:5]) # date and time at quit + writes(histfile, right(elapsed, 5), "s") # elapsed time in sec + writes(histfile, right(nmoves, 4), "m") # moves made + writes(histfile, right(undealt, 3), "c") # undealt cards + + every i := 1 to 10 do { + s := pile[i] + u := up[i] + if *s = 0 then + writes(histfile, " -") + else + writes(histfile, " ", s[1+:u], repl("?", *s-u)) + } + + write(histfile) + return +end diff --git a/ipl/gprogs/trkvu.icn b/ipl/gprogs/trkvu.icn index 9cd3c36..18c9f39 100644 --- a/ipl/gprogs/trkvu.icn +++ b/ipl/gprogs/trkvu.icn @@ -6,7 +6,7 @@ # # Authors: Gregg M. Townsend # -# Date: October 1, 2005 +# Date: April 3, 2010 # ############################################################################ # @@ -34,7 +34,7 @@ # # Track log colorings are selected by pressing a key: # -# F color by File +# F color by File (restricting legend to files in view) # A color by Age # O color by Orientation (direction of travel) # V color by Velocity @@ -105,7 +105,7 @@ record view( # one view of data record point( # one point along a track t, # time at point (real days & fraction since epoch) x, y, # coordinates of point (longitude, latitude) - fhue) # hue assigned to original source file + f) # file index global viewlist # list of views (view records) @@ -208,13 +208,10 @@ end procedure load(fname) # load data from one file local f, h, p, w, t, x, y, a, line, ptlist - static n - initial n := 0 f := open(fname) | stop("cannot open ", fname) - h := huenum(n +:= 1) put(fnlist, fname) - put(fhlist, h) + put(fhlist, huenum(*fnlist)) while line := read(f) do { every put(w := [], words(line)) if -90.0 <= numeric(w[-3]) <= 90.0 then @@ -222,7 +219,7 @@ procedure load(fname) # load data from one file if x := numeric(w[-1]) & y := numeric(w[-2]) then { t := tcrack(w[-4], w[-3]) | &null /ptlist := [] - put(ptlist, p := point(t, x, y, h)) + put(ptlist, p := point(t, x, y, *fnlist)) } else { put(seglist, \ptlist) @@ -245,7 +242,7 @@ procedure tcrack(date, time) # translate date + time into real value if date[3] == "/" then date := map("CcYy/Mm/Dd", "Mm/Dd/CcYy", date) - if date == ("1989/12/31" | "1990/01/01") then + if date <<= "1990/01/01" then # if indicator of missing date return &null *time = 8 | fail *date = 10 | fail @@ -387,7 +384,7 @@ procedure draw(win, pjn, a) # display map using curview GotoXY(2 * BORDER, lbase) ltext(curview.ltitle) ltext(": ") - curview.lproc() + curview.lproc(pjn) Clip ! mclip every ptlist := !seglist do { @@ -460,17 +457,48 @@ end # F: color segments by source file, using colors set at load time +# +# show in the legend only those files containing a point in view +# (note: won't show legend for tracks that "just pass through") + +procedure flegend(pjn) + local winlim, viewlim, fset, vset, i, seg, pt, x0, x1, y0, y1 + + fset := set() # set of potential file source indices + every insert(fset, 1 to *fnlist) + vset := set() # set of indices of files in view + + # find limits of the current field of view + winlim := [mclip[1], mclip[2] + mclip[4], mclip[1] + mclip[3], mclip[2]] + viewlim := project(invp(pjn), winlim) + x0 := get(viewlim) + y0 := get(viewlim) + x1 := get(viewlim) + y1 := get(viewlim) + + # find files in view + every seg := !seglist do { + pt := !seg # first pt + if member(fset, pt.f) then { + every pt := !seg do { + if x0 <= pt.x <= x1 & y0 <= pt.y <= y1 then { + delete(fset, pt.f) + insert(vset, pt.f) + if *fset = 0 then + break break + } + } + } + } -procedure flegend() - local i - - every i := 1 to *fnlist do + # now, finally draw the legend + every i := !sort(vset) do lhue(fhlist[i], fnlist[i] || " ") return end procedure byfile(p, q) - return q.fhue + return fhlist[q.f] end diff --git a/ipl/gprogs/tron.icn b/ipl/gprogs/tron.icn new file mode 100644 index 0000000..7fefc04 --- /dev/null +++ b/ipl/gprogs/tron.icn @@ -0,0 +1,191 @@ +############################################################################ +# +# File: tron.icn +# +# Subject: Program to play a Tron-like video game +# +# Author: Eduardo Ochs <eduardoochs@gmail.com> +# +# Date: November 18, 2009 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Rules: You're yellow, and you leave a yellow trail when you walk. +# You never stop until you die. You die when you hit something +# yellow. Use the arrow keys to change your direction. Try to make +# the best score you can before you die. You only live once. +# +# In the beginning it's a black arena with yellow walls and a red +# 3x3 pixel square somewhere. Walking over a red pixel gives you +# one point and makes another 3x3 square appear somewhere. So, +# crossing a 3x3 red square from one side to another gives you +# three points and makes three other squares appear in random +# positions. +# +# Walking over black pixels is harmless. +# +# Sometimes the red squares will appear over your trail. Then some +# pixels of your trail will become red and you'll be able to cross. +# +# The game loop and the outer loop: typing "Q" or Esc or losing when +# you're playing makes you go to the outer loop; in the outer loop +# typing "P" or Enter or space restarts the game, and typing "Q" or +# Esc leaves the program. +# +# Source: <http://angg.twu.net/ICON/tron.icn> +# Htmlized: <http://angg.twu.net/ICON/tron.icn.html> +# Screenshot: <http://angg.twu.net/ICON/tron.icn.png> +# See also: <http://angg.twu.net/elisp/tron.el.html> +# <http://angg.twu.net/elisp/tron.el.png> +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: graphics, random +# +############################################################################ + +link graphics +link random + +$include "keysyms.icn" + +global actions, direction +global x, y, dx, dy +global score +global pixels + +procedure prepare_vars() + actions := table() + actions[Key_Down] := ["v", +1] + actions[Key_Up] := ["v", -1] + actions[Key_Right] := ["h", +1] + actions[Key_Left] := ["h", -1] + every actions["q" | "Q" | "\e"] := "quit" + set_direction(["h", +1]) + x := 150 + y := 90 + score := 0 + pixels := table() + every pixels[0 to 199] := table(0) +end + +procedure set_color(n) + if n == 0 then WAttrib("fg=black") + if n == 1 then WAttrib("fg=red") + if n == 3 then WAttrib("fg=yellow") +end + +procedure pset(x, y, color) + set_color(color) + pixels[y][x] := color + FillRectangle(x*2, y*2, 2, 2) +end + +procedure point(x, y) + return pixels[y][x] +end + +procedure draw_red_square() + local x, y + x := ?316 + y := ?188 + every pset(x to x+2, y to y+2, 1) +end + +procedure is_direction(action) + return type(action) == "list" +end + +procedure ignored_turn(newdirection) + return newdirection[1] == direction[1] +end + +procedure set_direction(newdirection) + direction := newdirection + if direction[1] == "h" then { + dx := direction[2]; dy := 0 + } else { + dy := direction[2]; dx := 0 + } +end + +procedure process_events() + local e, action + while *Pending() > 0 do { + e := Event() + # w(e) + action := actions[e] + if is_direction(action) then { + if not ignored_turn(action) then { + set_direction(action) + return + } + } + if action === "quit" then + fail + } + return +end + +procedure prepare_walls() + every pset(0 to 319, 0, 3) + every pset(0 to 319, 191, 3) + every pset(0, 0 to 191, 3) + every pset(319, 0 to 191, 3) +end + +procedure draw_score() + GotoXY(6, 396) + set_color(3) + WWrites("Score: " || score) +end + +procedure play() + prepare_vars() + set_color(0) + FillRectangle(0, 0, 640, 400) + prepare_walls() + pset(x, y, 3) + draw_red_square() + draw_score() + + WDelay(1000) + + while process_events() do { + x +:= dx + y +:= dy + if point(x, y) == 3 then break + if point(x, y) == 1 then { + draw_red_square(); score +:= 1; draw_score() + pset(x, y, 3) + WDelay(50) + } + pset(x, y, 3) + WDelay(50) + } +end + +procedure main(args) + local e + + # w(actions) + WOpen("size=640,400", "fg=yellow", "bg=black") + WAttrib("font=Helvetica,12,bold") + + randomize() + while 1 do { + play() + while e := Event() do { + if e === ("q" | "Q" | "\e") then return + if e === ("p" | "P" | " " | "\r" | "\n") then break + } + } +end |