+# qmazer -- create a maze and then find the shortest path through it. +# The maze creation was taken from a Unicon solution to a RosettaCode +# problem. +#
+#+# (In this version, the maze creation only builds mazes with a single +# successful path but the path search is generalized to locate the shortest +# path in any maze with a single entry.) +#
+#+# The default maze size is suitable for an HD display, for a 4K display +# try cols=185 and rows=100. +#
+ +global showMice, showPaths +global start, finish +global delayms +global fullPath, visited + +import util +link printf + +$define CELL 20 # cell size in pixels +$define BORDER 30 # border size in pixels + +#+# Display a 2D maze, wait for a mouse click then solve the maze and wait for a +# second click to terminate program. +#
+# Arguments (all are optional): +#+# help -- display a help message +# showpaths -- put a mark on each maze cell as it's seen +# showmice -- show the individual mice as they traverse the maze +# cols=COLS -- set the number of columns [default: 88] +# rows=ROWS -- set the number of rows [default: 48] +# delay=MS -- delay between mouse movements in milliseconds [default: 0] +#+procedure main(A) + Args(A) + if \Args().getOpt("help","yes") then helpMesg() + showPaths := Args().getOpt("showpaths","yes") # Show mice (dead or alive) + showMice := Args().getOpt("showmice","yes") # Show all live mice + mh := Args().getOpt("rows") | 48 # Maze height (rows) + mw := Args().getOpt("cols") | 88 # Maze width (columns) + delayms := Args().getOpt("delay") # Delay between mice creations + fullPath := [] # Points in best path + + mz := DisplayMaze(GenerateMaze(mh,mw)) # Build and show maze + + QMouse(mz.maze,findStart(mz.maze),&null,0) # Start first quantum mouse + waitForCompletion() # block until all quantum mice have finished + + # Mark the best path into the maze and display it. + if showPath(mz.maze) then DisplayMazeSolution(mz) + else { # Give the person time to examine the failed maze search... + write("No path found for maze!") + DisplayMazeSolution(mz) + } +end + +procedure helpMesg() + write(&errout,"Usage: qMazer [--showmice] [--cols=C] [--rows=R]") + write(&errout,"\twhere:") + write(&errout,"\t\t--showmice # displays all mice as they search") + write(&errout,"\t\t--showpaths # displays all mice paths as they search") + write(&errout,"\t\t--cols=C # sets maze width to C (default 88) columns") + write(&errout,"\t\t--rows=R # sets maze height to R (default 48) rows") + write(&errout,"\t\t--delay=ms # delay ms millisecond (default none) between mice creations") + stop() +end + +# A "Quantum-mouse" for traversing mazes. Each mouse lives for exactly one +# cell, but can spawn additional mice to examine adjacent cells as needed. + +global qMice, bestMouse, bestMouseLock, region, qMiceEmpty +record Position(r,c) + +# Must match values used in maze generation! +$define FINISH 64 # exit +$define START 32 # entrance +$define PATH 128 +$define SEEN 16 # bread crumbs for generator +$define NORTH 8 # sides ... +$define EAST 4 +$define SOUTH 2 +$define WEST 1 +$define EMPTY 0 # like new + +class QMouse(maze, loc, parent, len, val) + + method getLoc(); return loc; end + + method getParent(); return \parent; end + + method getLen(); return len; end + + method atEnd(); return EMPTY ~= iand(val, FINISH); end + + method goNorth() + if EMPTY ~= iand(val,NORTH) then return visit(loc.r-1, loc.c) + end + + method goSouth() + if EMPTY ~= iand(val,SOUTH) then return visit(loc.r+1, loc.c) + end + + method goEast() + if EMPTY ~= iand(val,EAST) then return visit(loc.r, loc.c+1) + end + + method goWest() + if EMPTY ~= iand(val,WEST) then return visit(loc.r, loc.c-1) + end + + method visit(r,c) + static cw := Clone("linewidth=2","fg=grey") + local p + # Only visit a cell if it makes sense to do so (not already seen and + # not on a path longer than the best known solution). + critical region[r,c]: + if EMPTY = iand(maze[r,c],SEEN) then { + if /bestMouse | (len <= bestMouse.getLen()) then { # Keep going + if \showPaths then { + DrawLine(cw,CELL*(c-1),CELL*(r-1), + CELL*(loc.c-1),CELL*(loc.r-1)) + } + mark(maze, r,c) + unlock(region[r,c]) + return Position(r,c) + } + } + end + +initially (m, l, p, n) + initial { # Construct critical region mutexes and completion condvar + qMice := mutex(set()) + qMiceEmpty := condvar() + bestMouseLock := mutex() + region := list(*m) # Minimize critical region size + every r := 1 to *m do region[r] := list(*m[1]) + every !!region := mutex() + } + maze := m + loc := l + parent := p + len := n+1 + val := maze[loc.r,loc.c] | fail # Fail if outside maze + insert(qMice, self) + delay(\delayms) + thread { + if atEnd() then { + critical bestMouseLock: + if /bestMouse | (len < bestMouse.getLen()) then bestMouse := self + } + else { # Try to spawn more mice to look for finish + QMouse(maze, goNorth(), self, len) + QMouse(maze, goSouth(), self, len) + QMouse(maze, goEast(), self, len) + QMouse(maze, goWest(), self, len) + } + + delete(qMice, self) + if /showPaths then markCell(loc.r,loc.c,"white",5) + if *qMice=0 then signal(qMiceEmpty) + } +end + +procedure mark(maze, r,c, fg) + /fg := "grey" + maze[r,c] := ior(maze[r,c],SEEN) + if \(showMice|showPaths) then markCell(r,c,fg,5) + return Position(r,c) +end + +procedure clearMaze(maze) # Clear out dregs from maze creation + every r := 1 to *maze & c := 1 to *maze[1] do # remove breadcrumbs + maze[r,c] := iand(maze[r,c],NORTH+EAST+SOUTH+WEST+START+FINISH) +end + +procedure findStart(maze) # Anywhere in maze + clearMaze(maze) # Remove breadcrumbs + every r := 1 to *maze & c := 1 to *maze[1] do # Locate START cell + if EMPTY ~= iand(maze[r,c],START) then + return mark(maze, r,c, "red") +end + +procedure showPath(maze) + if path := \bestMouse then { # Mark it in maze + repeat { + loc := path.getLoc() + # Remember the path so its cells can be connected by line segments + put(fullPath,CELL*(loc.c-1),CELL*(loc.r-1)) + maze[loc.r,loc.c] +:= PATH + path := \path.getParent() | break + } + return + } +end + +procedure waitForCompletion() + critical qMiceEmpty: while *qMice > 0 do wait(qMiceEmpty) +end + +procedure GenerateMaze(r,c) # Non-recursive depth first maze generation +local maze,h,w,rd + /h := integer(1 < r) | runerr(r,205) # valid size 2x2 or better + /w := integer(1 < c) | runerr(r,205) + # The maze is a 2-D array implemented as a list of lists, where each cell + # holds bit flags (see line 80 and following for the possible flags). + # Note that the flags denoting directions indicate a direction to another + # cell that is reachable by going in that direction (e.g. the flag NORTH + # indicates that there is no wall between this cell and its northern + # neighbor). + every !(maze := list(h)) := list(w,EMPTY) # shiny new empty maze + # (each cell starts with 4 walls) + start := [?h,?w,?4-1,START] # random [r,c] start & finish + finish := [?h,?w,(start[3]+2)%4,FINISH] # w/ opposite side exponent + every x := start | finish do { + case x[3] := 2 ^ x[3] of { # get side from exponent and + NORTH : x[1] := 1 # project r,c to selected edge + EAST : x[2] := w + SOUTH : x[1] := h + WEST : x[2] := 1 + } + maze[x[1],x[2]] +:= x[3] + x[4] # transcribe s/f to maze + } + maze[start[1],start[2]] +:= SEEN + push(visited := [], Position(start[1],start[2])) + rd := [NORTH, EAST, SOUTH, WEST] # initial list of directions + while *visited > 0 do { + p := pop(visited) + r := p.r + c := p.c + if maze[r,c] then { # in bounds + every !rd :=: ?rd # randomize list of directions + xp := &null # This forces depth-first! + every d := !rd do + case d of { # try all, if succeed: clear wall + NORTH : if np := chkPos(maze,r-1,c,p, NORTH) then { + if /xp then (push(visited,p),xp := "putback") + push(visited, np) + break + } + EAST : if np := chkPos(maze,r,c+1,p, EAST) then { + if /xp then (push(visited,p),xp := "putback") + push(visited, np) + break + } + SOUTH : if np := chkPos(maze,r+1,c,p, SOUTH) then { + if /xp then (push(visited,p),xp := "putback") + push(visited, np) + break + } + WEST : if np := chkPos(maze,r,c-1,p, WEST) then { + if /xp then (push(visited,p),xp := "putback") + push(visited, np) + break + } + } + } + } + return maze +end + +procedure chkPos(maze,r,c,p,wall) + # If the new cell is inside the maze and hasn't been visited yet, + # remove the wall between the old and new cells and return the new cell + if iand(maze[r,c], SEEN) = EMPTY then { + maze[r,c] +:= SEEN + maze[p.r,p.c] +:= wall + return Position(r,c) + } +end + +record mazeinfo(window,maze,filename) # keepers + +procedure DisplayMaze(maze) #: show it off + if CELL < 8 then runerr(205,CELL) # too small + + wh := (ch := (mh := *maze ) * CELL) + 2 * BORDER # win, cell, maze height + ww := (cw := (mw := *maze[1]) * CELL) + 2 * BORDER # win, cell, maze width + + wparms := [ sprintf("Maze %dx%d",*maze,*maze[1]), # window parameters + "g","bg=white","canvas=hidden", + sprintf("size=%d,%d",ww,wh), + sprintf("dx=%d",BORDER), + sprintf("dy=%d",BORDER)] + + &window := open!wparms | stop("Unable to open Window") + + Fg("black") # Draw full grid + every DrawLine(x := 0 to cw by CELL,0,x,ch+1) # . verticals + every DrawLine(0,y := 0 to ch by CELL,cw+1,y) # . horizontals + + Fg("white") # Set to erase lines + every y := CELL*((r := 1 to mh)-1) & x := CELL*((c := 1 to mw)-1) do { + WAttrib("dx="||x+BORDER,"dy="||y+BORDER) # position @ cell r,c + if iand(maze[r,c],NORTH) ~= EMPTY then DrawLine(2,0,CELL-1,0) + if iand(maze[r,c],EAST) ~= EMPTY then DrawLine(CELL,2,CELL,CELL-1) + if iand(maze[r,c],SOUTH) ~= EMPTY then DrawLine(2,CELL,CELL-1,CELL) + if iand(maze[r,c],WEST) ~= EMPTY then DrawLine(0,2,0,CELL-1) + } + + WAttrib(&window,"canvas=normal") + WAttrib("dx="||(dxy:=BORDER+CELL/2),"dy="||dxy) + colorCell(start[1],start[2], "red", 3) + colorCell(finish[1],finish[2], "green", 3) + until Event() == &lpress + return mazeinfo(&window,maze,sprintf("maze-%dx%d-%d.gif",r,c,&now)) +end + +procedure DisplayMazeSolution(mz) #: draw marked PATH + &window := mz.window + maze := mz.maze + WAttrib("dx="||(dxy:=BORDER+CELL/2),"dy="||dxy) + # First, draw a line through the full path. + if *fullPath > 0 then { + push(fullPath, Clone("linewidth=3","fg=blue")) + DrawLine!fullPath + } + every (r := 1 to *maze) & (c := 1 to *maze[1]) do { + fg := "blue" + if iand(maze[r,c],START) ~= EMPTY then fg := "red" + if iand(maze[r,c],FINISH) ~= EMPTY then fg := "green" + if iand(maze[r,c],PATH) ~= EMPTY then markCell(r,c,fg,3) + } + until Event() == &lpress + close(&window) + return mz +end + +procedure markCell(r,c,fg,sz) + initial WAttrib("dx="||(dxy:=BORDER+CELL/2),"dy="||dxy) + colorCell(r,c,fg,sz) +end + +procedure colorCell(r,c,fg,sz) + Fg(fg) + FillCircle(CELL*(c-1),CELL*(r-1),CELL/sz) +end + diff --git a/uni/progs/complex_ex.icn b/uni/progs/complex_ex.icn new file mode 100644 index 000000000..1ddcac1f7 --- /dev/null +++ b/uni/progs/complex_ex.icn @@ -0,0 +1,20 @@ +#
+# complex_ex Example using Unicon's operator overloading and the +# Complex class (complex negation is not provided by the class) +# Requires that Unicon be configured with the --enable-ovld +# flag set. +#
+ +import math + +procedure main() + write("c1: ",(c1 := Complex(1.5,3)).toString()) + write("c2: ",(c2 := Complex(1.5,1.5)).toString()) + write("+: ",(c1+c2).toString()) + write("-: ",(c1-c2).toString()) + write("*: ",(c1*c2).toString()) + write("/: ",(c1/c2).toString()) + write("additive inverse: ",c1.addInverse().toString()) + write("multiplicative inverse: ",c1.multInverse().toString()) + write("conjugate of (4,-3i): ",Complex(4,-3).conjugate().toString()) +end diff --git a/uni/progs/rankvote.icn b/uni/progs/rankvote.icn new file mode 100644 index 000000000..6c6e4d8e7 --- /dev/null +++ b/uni/progs/rankvote.icn @@ -0,0 +1,164 @@ +#+# Implement ranked choice voting. +#
+#+# Author: Stephen Wampler (sbw@tapestry.tucson.az.us) +#
+#+# This program is in the public domain. +#
+ +import util +link printf # For sprintf + +global ballots, # Individual ballots + totalVotes, # Total votes for first candidate on each ballot, per round + results, # How each round turned out + maxcands # Most candidates on any ballot (needed in tie-breaks) + +#+# Read in ranked-choice ballots where each ballot is a single line with the +# candidates ordered from first to last choice separated by commas. +# Output the winning candidate. +# This is not intended for use where a "split-ballot" is used. +#
+#+# The arguments, if present, are the files that +# contain the ballots. Multiple ballots may appear in each file. If no files +# are listed then &input is used. +# Also accepts an option --verbose to see more details of the +# rounds of the ranked-choice voting and --help can be used to get +# a simple help message. +# <[param A - arguments and options, if any]> +#
+procedure main(A) + Args(A,set(["verbose","help"]),helpMesg) + if Args().getOpt("help") then { + helpMesg() + stop() + } + files := Args().getArgs() + if *files > 0 then every readBallots(f := open(!files)) do close(f) + else readBallots(&input) + while not majority() do removeWorst() + showResult() +end + +#+# Display a help message. +#
+procedure helpMesg() + write(&errout, "Usage: rankvote [--verbose] [ballotfile...]") + write(&errout, " reads ballots from &input if no ballotfiles listed") +end + +#+# Constructs a list of ballots as read from a file. +# Each line is a single ballot with candidates ordered from first to last +# choice, separated by commas. A candidate's name may include commas if it +# is embedded in double quotes. +# <[param f - file containing ballots, already opened]> +#
+procedure readBallots(f) + initial { + ballots := [] + maxcands := 0 + } + every put(ballots, b := parseCSV(!f,',')) do maxcands <:= *b + return +end + +#+# Check to see if any candidate has a clear majority. +#<[succeeds if a candidate has a clear majority]> +#<[fails if no candidate has a clear majority yet]> +#
+procedure majority() + results := computeRanks() + if Args().getOpt("verbose") then showAllResults() + if percentVote(results[-1]) > 50.0 then return +end + +#+# Compute the current ranking based on first choices. +# <[returns a list of candidates ranked from last to first]> +#
+procedure computeRanks() + curRanking := table() + totalVotes := 0 + # Start by tallying counts for all first choices + every *(b := !ballots) > 0 do { # Ignore empty ballots + every c := !b do /curRanking[c] := 0 # Pass all candidates through + curRanking[b[1]] +:= 1 + totalVotes +:= 1 + } + return sort(curRanking,2) # Worst candidate is first in list! +end + +#+# Find the remaining candidate with the fewest first-place votes and +# remove them. +# Handles tie breaks. +#
+procedure removeWorst() + worst := results[1] + worst2 := results[2] # Needed to check for ties... + if percentVote(worst) < percentVote(worst2) then removeCandidate(worst) + else tieBreak(worst1,worst2) +end + +#+# Remove a candidate (always one with the fewest first-place votes, of course!) +# <[param worst - worst candidate as a list [name,number of votes for first]> +#
+procedure removeCandidate(worst) + write("\tRemoving '",worst[1],"' with ",percentVote(worst),"% of votes") + every b := !ballots do + every i := 1 to *b do if worst[1] == b[i] then delete(b,i) +end + +#+# Break a tie for the worst remaining candidate by removing the candidate +# that has the lowest cummulative ranking. Factor in that some ballots may +# not include all candidates. +#
+procedure tieBreak(A[]) + if Args().getOpt("verbose") then write("\tGoing to tie breaker!") + tb := table() + every c := \!A do { + cVotes := 0 + every b := !ballots do { + every i := 1 to *b do if b[i] == c[1] then cVotes +:= (maxcands+1)-i + } + tb[c[1]] := cVotes # 0 if candidate c not on ballot b + } + worst := sort(tb,2)[1] + every i := 1 to *results do + if worst[1] == results[i][1] then break removeCandidate(results[i]) +end + +#+# Compute the percent of first-place votes a candidate has in the current +# round. +# <[param candidate - a candidate as a list [name,number of votes for first]>. +# <[returns percent of total votes that the candidate has]> +#
+procedure percentVote(candidate) + return sprintf("%8.4r",100.0*candidate[2]/real(totalVotes)) +end + +#+# Show the results for the current round. +#
+procedure showAllResults() + write("Current results for ",*results," candidate:") + every c := !results do write("\t",c[1]," -> ",percentVote(c),"%") +end + +#+# Show the final round's winner. +#
+procedure showResult() + write("Winner is '",results[-1][1],"' with ",percentVote(results[-1]),"% ", + "of votes.") +end