Imported Upstream version 9.5.0upstream/9.5.0upstream

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