Multithreading Puzzles [closed] - multithreading

As it currently stands, this question is not a good fit for our Q&A format. We expect answers to be supported by facts, references, or expertise, but this question will likely solicit debate, arguments, polling, or extended discussion. If you feel that this question can be improved and possibly reopened, visit the help center for guidance.
Closed 9 years ago.
I'm trying to come up with some programming puzzles focused on multi-threading. Most of the problems I've been able to come up with, so far, have been pretty domain specific. Does anybody have any decent programming puzzles for developers attempting to learn the core concepts of multi-threading applications?

There are a number of topics covered at this link.
Multithreaded Programming with ThreadMentor : A Tutorial
Edit:
Here are some direct links to the problems listed at that link, along with their initial descriptions.
ThreadMentor : The Dining Philosopher's Problem
ThreadMentor : The Dining Philosopher's Problem: The Lefty-Righty Version
The dining philosophers problem is invented by E. W. Dijkstra. Imagine that five philosophers who spend their lives just thinking and easting. In the middle of the dining room is a circular table with five chairs. The table has a big plate of spaghetti. However, there are only five chopsticks available, as shown in the following figure. Each philosopher thinks. When he gets hungry, he sits down and picks up the two chopsticks that are closest to him. If a philosopher can pick up both chopsticks, he eats for a while. After a philosopher finishes eating, he puts down the chopsticks and starts to think.
ThreadMentor : The Cigarette Smoker's Problem
This problem is due to S. S. Patil in 1971. Suppose a cigarette requires three ingredients, tobacco, paper and match. There are three chain smokers. Each of them has only one ingredient with infinite supply. There is an agent who has infinite supply of all three ingredients. To make a cigarette, the smoker has tobacco (resp., paper and match) must have the other two ingredients paper and match (resp., tobacco and match, and tobacco and paper). The agent and smokers share a table. The agent randomly generates two ingredients and notifies the smoker who needs these two ingredients. Once the ingredients are taken from the table, the agent supplies another two. On the other hand, each smoker waits for the agent's notification. Once it is notified, the smoker picks up the ingredients, makes a cigarette, smokes for a while, and goes back to the table waiting for his next ingredients.
ThreadMentor : The Producer/Consumer (or Bounded-Buffer) Problem
Suppose we have a circular buffer with two pointers in and out to indicate the next available position for depositing data and the position that contains the next data to be retrieved. See the diagram below. There are two groups of threads, producers and consumers. Each producer deposits a data items into the in position and advances the pointer in, and each consumer retrieves the data item in position out and advances the pointer out.
ThreadMentor : The Roller Coaster Problem
Suppose there are n passengers and one roller coaster car. The passengers repeatedly wait to ride in the car, which can hold maximum C passengers, where C < n. However, the car can go around the track only when it is full. After finishes a ride, each passenger wanders around the amusement park before returning to the roller coaster for another ride. Due to safety reasons, the car only rides T times and then shot-off.
This one has additional constraints:
The car always rides with exactly C passengers;
No passengers will jump off the car while the car is running;
No passengers will jump on the car while the car is running;
No passengers will request another ride before they can get off the car.
ThreadMentor : The Bridge Problem
The description for this one relies on images. Here is a modified quote with image references removed.
Consider a narrow bridge that can only allow three vehicles in the same direction to cross at the same time. If there are three vehicles on the bridge, any incoming vehicle must wait until the bridge is clear.
When a vehicle exits the bridge, we have two cases to consider. Case 1, there are other vehicles on the bridge; and Case 2 the exiting vehicle is the last one on bridge. In the first case, one new vehicle in the same direction should be allowed to proceed.
Case 2 is more complicated and has two subcases. In this case, the exiting vehicle is the last vehicle on the bridge. If there are vehicles waiting in the opposite direction, one of them should be allowed to proceed. Or, if there is no vehicle waiting in the opposite direction, then let the waiting vehicle in the same direction to proceed.

The Dining Philosophers Problem, is the first one I think of.

You have a large tree structure in memory. Many threads need to search the structure. Occasionally, a thread will need to insert or remove something from the structure. How do you control access to the structure so that the program will run correctly (no two threads will stomp on each other while changing the structure) and efficiently (no threads are blocked when they don't have to be)?

The Sleeping Barber Problem springs to mind, as does the Cigarette Smokers Problem.

Dining philosophers is one...
unisex bathroom is another one

Perhaps you can use the simple problem of testing and setting a shared flag or accessing some kind of list resource in some kind of sequentially consistent manner?

The Producer-Consumer problem.

Here's the first problem I ever completed with multi-threading, back during my undergraduate studies.

An Elevator Simulator is pretty common.

Depending upon what you are doing with your multi-threading, this makes a difference.
You are in a bank. Customers arrive at an average rate of 1 every 2 minutes. Each customer is served, on average, in 2 minutes.
Which is the better solution to serving the customers? One common line, or one line for each teller?
Is your choice enough to guarantee some bound on the length of the line?
Answers: because of the markov property of customer arrival and actual service time per individual, the line will never know a bound. additionally, it's a good idea to make them wait in one common line, although this is not enough to overcome the boundless line.

Here's a parallel N-puzzle solver implemented in PARLANSE. The language has a LISP-like syntax but is really closer to C (scalars, structs, pointers, function calls), but unlike C has local scopes. The secret is in the parallel fork-grain operator (|| ... ) which executes all of its operands in parallel, as well as PARLANSE's ability to use exceptions to stop parent grains.
This solver delivers linear speedups on all the 4 and 8 way machines on which I have tried it.
(define Version `N-puzzle Solver V1.1~l
Copyright (C) 1998-2009 Semantic Designs; All Rights Reserved~l')
(define SolveParticularPuzzle ~t)
(define ManhattanHeuristic ~t) ; Manhattan is really fast
(define PrintTrace ~f)
(include `parmodule.par')
(define ScrambleCount 10000)
(define PuzzleSize `Length of side of N-puzzle' +4) ; at least 3!
(define PuzzleSizeMinus1 +3)
(define PuzzleArea `Area of puzzle (= (-- N))' +16) ; (= (* PuzzleSize PuzzleSize))
(define PuzzleAreaMinus1 +15)
(define BlankTile `Code for a blank tile' 0)
(define puzzlepieceT `Codes for nonblank tiles'
(sort natural (range 1 PuzzleArea)))
(define BoardPositionT integer) ; normally positive, but sometime we reach off the edge
(define ConfigurationT (array puzzlepieceT 0 PuzzleAreaMinus1))
(define HardPuzzle1 `Solution found of length 29:
2 1 5 6 2 3 7 11 10 6 2 3 7 11 10 14 13 9 8
12 13 9 5 1 2 6 5 1 0'
(lambda (function ConfigurationT void)
(make ConfigurationT 01 11 02 00
04 06 09 05
13 12 07 03
08 14 10 15)
)lambda
)define
(define HardPuzzle2 `Solution found of length 31:
0 4 5 6 10 9 5 1 2 3 7 6 10 9 5 1
2 3 7 6 5 1 2 6 1 0 14 13 9 5 4 0'
(lambda (function ConfigurationT void)
(make ConfigurationT 13 00 02 09
04 05 06 01
08 07 03 11
12 14 10 15)
)lambda
)define
(define HardPuzzle3 `Solution found of length 56:
1 2 6 7 3 2 6 10 14 15 11 10 9 5
4 8 12 13 9 10 6 5 1 0 4 8 12 13
14 10 6 7 11 10 9 13 14 15 11 10
6 5 4 8 9 10 6 5 1 0 4 8 9 5 4 0
Total solution time in seconds: 18-24 (on 8 processor machine)'
(lambda (function ConfigurationT void)
(make ConfigurationT 00 09 10 08
15 12 03 02
01 11 13 14
06 04 07 05)
)lambda
)define
(define HardPuzzle4 `Solution found of length 50:
4 5 1 0 4 8 12 13 9 5 1 0 4 5 6
10 14 13 9 8 4 5 6 2 1 5 9 10 14
13 12 8 9 10 11 15 14 13 9 10 11
7 3 2 1 5 9 8 4 0
Total solution time in seconds: 125 (on 8 processor machine)'
(lambda (function ConfigurationT void)
(make ConfigurationT 00 15 06 07
12 03 08 11
04 13 02 05
01 14 09 10)
)lambda
)define
(define HardPuzzle5
`Solution found of length 68:
3 7 11 10 6 2 3 7 6 5 9 8 4 5 1 0 4 5 9 13 14 15 11
7 6 5 1 2 6 5 9 8 12 13 14 10 6 5 4 8 12 13 14 15 11
10 9 5 1 0 4 8 12 13 9 5 4 8 9 13 14 15 11 7 3 2 1 0
Total solution time in seconds: 2790 (on 8 processor machine)'
(lambda (function ConfigurationT void)
(make ConfigurationT 15 09 00 14
10 11 12 08
03 02 13 07
01 06 05 04)
)lambda
)define
(define ParticularPuzzleToSolve HardPuzzle5)
(define PrintConfiguration
(action (procedure [Puzzle (reference ConfigurationT)])
(do [position BoardPositionT] +0 PuzzleAreaMinus1 +1
(;; (ifthenelse (<= Puzzle:position 9)
(;; (PAR:PutConsoleCharacter "0")(PAR:PutConsoleNatural Puzzle:position) );;
(PAR:PutConsoleNatural Puzzle:position)
)ifthenelse
(PAR:PutConsoleSpace)
(ifthen (== (modulo (coerce natural position) (coerce natural PuzzleSize))
(coerce natural PuzzleSizeMinus1)coerce )==
(PAR:PutConsoleNewline)
)ifthen
);;
)do
)action
)define
(define Solved? `Determines if puzzle is solved.'
(lambda (function boolean
[board (reference ConfigurationT)]
)function
(value (;; `Fast check for completed':
(ifthen (~= board:0 BlankTile)
(return ~f)
)ifthen
(do [position BoardPositionT] PuzzleAreaMinus1 +1 -1
(ifthen (~= board:position (coerce natural position))
(return ~f)
)ifthen
)do
);;
~t ; all pieces are in proper places
)value
)lambda
)define
(define ScoreT `Estimate of configuration distance from solution.
Zero means configuration is a solution.'
(sort natural (range 0 1000))) ; s/b (range 0 (* PuzzleArea PuzzleArea))
(define SolvedScore `The score of a goal position.' 0)
(define UnsolvableScore `An impossibly big score.' 12345678)
(define LowerBoundOnScore
(lambda (function ScoreT [Puzzle (reference ConfigurationT)])
(let (= [OutOfPlaceTiles ScoreT] 0)
(value
(compileifthenelse ManhattanHeuristic ; ~t for Out-of-place, ~f for Manhattan
(do [Row BoardPositionT] PuzzleSizeMinus1 +0 -1
(do [Column BoardPositionT] PuzzleSizeMinus1 +0 -1
(local (;; (= [position integer] (+ (* Row PuzzleSize)
Column))=
(= [tile puzzlepieceT] Puzzle:position)
);;
(ifthen (~= tile BlankTile) ; ignore BlankTile
(+= OutOfPlaceTiles
(+ (magnitude (- Row (coerce integer (// tile (coerce natural PuzzleSize)))))
(magnitude (- Column (coerce integer (modulo tile (coerce natural PuzzleSize)))))
)+ ; add Manhattan distance of tile from tile goal
)+=
)ifthen
)local
)do ; Column
)do ; Row
(do [position BoardPositionT] PuzzleAreaMinus1
+1 ; skipping zero effectively ignores BlankTile
+1
(ifthen (~= Puzzle:position (coerce natural position))
(+= OutOfPlaceTiles)
)ifthen
)do
)compileifthenelse
OutOfPlaceTiles ; the answer
)value
)let
)lambda
)define
(recursive PathElementT
(define PathElementT `A series of moves of the blank tile.'
(structure [Move BoardPositionT]
[Next (reference PathElementT)]
)structure
)define
)recursive
(define EmptyPath (void (reference PathElementT))void )define
(define ValuedPathT `A path and the score it acheives.'
(structure [Solved boolean]
[Score ScoreT]
[Path (reference PathElementT)])
)define
(define MakeMove `Applies a move to a configuration'
(lambda (function ConfigurationT
(structure [BlankTilePosition BoardPositionT]
[NewBlankPosition BoardPositionT]
[ConfigurationBeforeMove
(reference ConfigurationT)]
)structure )function
(let (= [ResultConfiguration ConfigurationT]
(# ConfigurationBeforeMove) )=
(value
(;;
(compileifthen PrintTrace
(;; (PAR:PutConsoleNatural BlankTilePosition)
(PAR:PutConsoleNatural NewBlankPosition)
);;
)compileifthen
(trust (== ConfigurationBeforeMove:BlankTilePosition
BlankTile))
(= ResultConfiguration:BlankTilePosition
ConfigurationBeforeMove:NewBlankPosition)
(= ResultConfiguration:NewBlankPosition BlankTile)
);;
ResultConfiguration
)value
)let
)lambda
)define
(define TopEdge? `Determines if a position is along top edge of puzzle.'
(lambda (function boolean BoardPositionT)
(< ? PuzzleSize)
)lambda
)define
(define BottomEdge? `Determines if a position is along bottom edge of puzzle.'
(lambda (function boolean BoardPositionT)
(>= ? (- PuzzleArea PuzzleSize))
)lambda
)define
(define LeftEdge? `Determines if a position is along left edge of puzzle.'
(lambda (function boolean BoardPositionT)
(== (modulo (coerce natural ?) (coerce natural PuzzleSize)) 0)==
)lambda
)define
(define RightEdge? `Determines if a position is along right edge of puzzle.'
(lambda (function boolean BoardPositionT)
(== (modulo (coerce natural ?) (coerce natural PuzzleSize))modulo
(coerce natural PuzzleSizeMinus1)coerce )==
)lambda
)define
(define Solved! (exception (lambda (function string (reference ValuedPathT))
`N-puzzle solution is:~l'
)lambda
)exception
)define
[SerialPrint semaphore]
[MaxMoves natural]
(define Npuzzle
(lambda (function ValuedPathT
[BlankTilePosition BoardPositionT]
[PreviousBlankTilePosition BoardPositionT]
[Puzzle ConfigurationT]
[MovesToHere natural]
)function
)lambda
)define
(define Npuzzle `Solves a puzzle and generates a sequence which is a solution.'
(lambda (function ValuedPathT
[BlankTilePosition BoardPositionT]
[PreviousBlankTilePosition BoardPositionT]
[Puzzle ConfigurationT]
[MovesToHere natural]
)function
(ifthenelse (value (compileifthen PrintTrace
(;; (PAR:PutConsole (. `In Npuzzle at depth '))
(PAR:PutConsoleNatural MovesToHere) (PAR:PutConsoleNewline)
(PrintConfiguration (. Puzzle))
);;
)compileifthen
(Solved? (. Puzzle)))
(make ValuedPathT ~t 0 EmptyPath)make ; the answer
(let (|| [valuedpath1 ValuedPathT]
[valuedpath2 ValuedPathT]
[valuedpath3 ValuedPathT]
[valuedpath4 ValuedPathT]
[Best ValuedPathT]
(= [EstimatedDistance natural]
(+ MovesToHere (LowerBoundOnScore (. Puzzle)))+ )=
)||
(ifthenelse (value (compileifthen PrintTrace
(;; (PAR:PutConsole (. `Inside LET EstimatedDistance= '))
(PAR:PutConsoleNatural EstimatedDistance) (PAR:PutConsoleNewline)
);;
)compileifthen
(> EstimatedDistance MaxMoves) )
(make ValuedPathT ~f EstimatedDistance EmptyPath) ; don't explore any further
(value
(;; (assert (& (<= +0 BlankTilePosition)
(< BlankTilePosition PuzzleArea) )& )assert
; (PAR:PutConsole (. `Solve subpuzzles: blank # '))(PAR:PutConsoleNatural BlankTilePosition)(PAR:PutConsoleNewline)
(try `Solve subpuzzles':
(|| ; replace this by (;; to see pure serial execution times
`Fork Right':
(local (|| (= [NewBlankTilePosition BoardPositionT]
(++ BlankTilePosition) )=
[ExtendedPath (reference PathElementT)]
)||
(ifthenelse (value (;; ; (PAR:PutConsole (. `Fork Right~l'))
);;
(&& (~= NewBlankTilePosition
PreviousBlankTilePosition )~=
(~ (RightEdge? BlankTilePosition))~
)&& )value
(;; (= valuedpath1
(Npuzzle NewBlankTilePosition
BlankTilePosition
(MakeMove BlankTilePosition
NewBlankTilePosition
(. Puzzle) )MakeMove
(++ MovesToHere)
)Npuzzle )=
(ifthen valuedpath1:Solved
(;; (+= valuedpath1:Score) ; since we added a move
(= ExtendedPath (new PathElementT))
(= (# ExtendedPath) (make PathElementT NewBlankTilePosition valuedpath1:Path) )=
(= valuedpath1:Path ExtendedPath)
(raise Solved! (. valuedpath1))
);;
)ifthen
);;
(= valuedpath1 (make ValuedPathT ~f UnsolvableScore EmptyPath))=
)ifthenelse
)local
`Fork Left':
(local (|| (= [NewBlankTilePosition BoardPositionT]
(-- BlankTilePosition) )=
[ExtendedPath (reference PathElementT)]
)||
(ifthenelse (value (;; ; (PAR:PutConsole (. `Fork Left~l'))
);;
(&& (~= NewBlankTilePosition
PreviousBlankTilePosition )~=
(~ (LeftEdge? BlankTilePosition))~
)&& )value
(;; (= valuedpath2
(Npuzzle NewBlankTilePosition
BlankTilePosition
(MakeMove BlankTilePosition
NewBlankTilePosition
(. Puzzle) )MakeMove
(++ MovesToHere)
)Npuzzle )=
(ifthen valuedpath2:Solved
(;; (+= valuedpath2:Score) ; since we added a move
(= ExtendedPath (new PathElementT))
(= (# ExtendedPath) (make PathElementT NewBlankTilePosition valuedpath2:Path) )=
(= valuedpath2:Path ExtendedPath)
(raise Solved! (. valuedpath2))
);;
)ifthen
);;
(= valuedpath2 (make ValuedPathT ~f UnsolvableScore EmptyPath))=
)ifthenelse
)local
`Fork Down':
(local (|| (= [NewBlankTilePosition BoardPositionT]
(- BlankTilePosition PuzzleSize) )=
[ExtendedPath (reference PathElementT)]
)||
(ifthenelse (value (;; ; (PAR:PutConsole (. `Fork Down~l'))
);;
(&& (~= NewBlankTilePosition
PreviousBlankTilePosition )~=
(~ (TopEdge? BlankTilePosition))~
)&& )value
(;; (= valuedpath3
(Npuzzle NewBlankTilePosition
BlankTilePosition
(MakeMove BlankTilePosition
NewBlankTilePosition
(. Puzzle) )MakeMove
(++ MovesToHere)
)Npuzzle )=
(ifthen valuedpath3:Solved
(;; (+= valuedpath3:Score) ; since we added a move
(= ExtendedPath (new PathElementT))
(= (# ExtendedPath) (make PathElementT NewBlankTilePosition valuedpath3:Path) )=
(= valuedpath3:Path ExtendedPath)
(raise Solved! (. valuedpath3))
);;
)ifthen
);;
(= valuedpath3 (make ValuedPathT ~f UnsolvableScore EmptyPath))=
)ifthenelse
)local
`Fork Up':
(local (|| (= [NewBlankTilePosition BoardPositionT]
(+ BlankTilePosition PuzzleSize) )=
[ExtendedPath (reference PathElementT)]
)||
(ifthenelse (value (;; ; (PAR:PutConsole (. `Fork Up~l'))
);;
(&& (~= NewBlankTilePosition
PreviousBlankTilePosition )~=
(~ (BottomEdge? BlankTilePosition))~
)&& )value
(;; (= valuedpath4
(Npuzzle NewBlankTilePosition
BlankTilePosition
(MakeMove BlankTilePosition
NewBlankTilePosition
(. Puzzle) )MakeMove
(++ MovesToHere)
)Npuzzle )=
(ifthen valuedpath4:Solved
(;; (+= valuedpath4:Score) ; since we added a move
(= ExtendedPath (new PathElementT))
(= (# ExtendedPath) (make PathElementT NewBlankTilePosition valuedpath4:Path) )=
(= valuedpath4:Path ExtendedPath)
(raise Solved! (. valuedpath4))
);;
)ifthen
);;
(= valuedpath4 (make ValuedPathT ~f UnsolvableScore EmptyPath))=
)ifthenelse
)local
) ; || or ;;
`Exception handler':
(;; ; (PAR:PutConsole (. `Exception handler~l'))
(ifthenelse (== (exception) Solved!)==
(;; (= Best (# (exceptionargument (reference ValuedPathT))))=
(acknowledge (;; );; )acknowledge
);;
(propagate) ; oops, something unexpected!
)ifthenelse
);;
`Success handler':
(;; ; (PAR:PutConsole (. `Success (no exception raised)!~l'))
`If we get here, no result is a solution,
and all results have leaf-estimated scores.'
(ifthenelse (< valuedpath1:Score valuedpath2:Score)
(= Best valuedpath1)
(= Best valuedpath2)
)ifthenelse
(ifthen (< valuedpath3:Score Best:Score)
(= Best valuedpath3) )ifthen
(ifthen (< valuedpath4:Score Best:Score)
(= Best valuedpath4) )ifthen
);;
)try
);;
Best ; the answer to return
)value
)ifthenelse
)let
)ifthenelse
)lambda
)define
[StartTimeMicroseconds natural]
(define ElapsedTimeSeconds
`Returns time in seconds rounded to nearest integer'
(lambda (function natural void)
(/ (- (+ (MicrosecondClock) 500000) StartTimeMicroseconds) 1000000)
)lambda
)define
(define main
(action (procedure void)
(local (|| [PuzzleToSolve ConfigurationT]
[BlankTilePosition BoardPositionT]
[Solution ValuedPathT]
[BlankLocation BoardPositionT]
[Neighbor BoardPositionT]
[PathScanP (reference PathElementT)]
[ElapsedTime natural]
)||
(;; (PAR:PutConsoleString Version)
(consume (addresource SerialPrint 1))
`Set PuzzleToSolve to Solved position':
(do [position BoardPositionT] +0 PuzzleAreaMinus1 +1
(= PuzzleToSolve:position (coerce puzzlepieceT position) )=
)do
(ifthenelse SolveParticularPuzzle
(;; (PAR:PutConsole (. `Hard puzzle...~l'))
(= PuzzleToSolve (ParticularPuzzleToSolve) )= );;
(;; `Scramble puzzle position'
(PAR:PutConsole (. `Random puzzle...~l'))
(= BlankLocation +0)
(do [i natural] 1 (modulo (MicrosecondClock)
ScrambleCount)modulo 1
(;; (= Neighbor BlankLocation)
(ifthenelse (== (PAR:GetRandomNat 2) 0)
(;; `Move Blank up or down'
(ifthenelse (== (PAR:GetRandomNat 2) 0)
(ifthen (~ (TopEdge? BlankLocation)) (-= Neighbor PuzzleSize))
(ifthen (~ (BottomEdge? BlankLocation)) (+= Neighbor PuzzleSize))
)ifthenelse
);;
(;; `Move Blank left or right'
(ifthenelse (== (PAR:GetRandomNat 2) 0)
(ifthen (~ (LeftEdge? BlankLocation)) (-= Neighbor))
(ifthen (~ (RightEdge? BlankLocation)) (+= Neighbor))
)ifthenelse
);;
)ifthenelse
; (PAR:PutConsoleNatural BlankLocation)(PAR:PutConsoleNatural Neighbor)(PAR:PutConsoleSpace)
(ifthen (~= BlankLocation Neighbor)
(= PuzzleToSolve
(MakeMove BlankLocation Neighbor (. PuzzleToSolve). )MakeMove )=
)ifthen
(= BlankLocation Neighbor)=
);;
)do
);;
)ifthenelse
(;; `Initialize solver'
(= Solution:Solved ~f)
(= Solution:Score 0)
(do FindBlankTile
[position BoardPositionT] +0 PuzzleAreaMinus1 +1
(ifthen (== PuzzleToSolve:position BlankTile)
(;; (= BlankTilePosition position)
(exitblock FindBlankTile)
);; )ifthen )do
);;
(PAR:PutConsole (. `~lInitial Configuration:~l'))
(PrintConfiguration (. PuzzleToSolve))
(PAR:PutConsole (. `Estimate of solution length: '))
(PAR:PutConsoleNatural (LowerBoundOnScore (. PuzzleToSolve)))
(PAR:PutConsoleNewline)
(= StartTimeMicroseconds (MicrosecondClock))
(while (~ Solution:Solved)
(;; (critical SerialPrint 1
(;; (PAR:PutConsole (. `*** Iteration to depth '))
(PAR:PutConsoleNatural Solution:Score)
(PAR:PutConsole (. ` ')) (PAR:PutConsoleNatural (ElapsedTimeSeconds)) (PAR:PutConsole (. ` Seconds'))
(PAR:PutConsoleNewline)
);;
)critical
(= MaxMoves Solution:Score)
(= Solution (Npuzzle BlankTilePosition BlankTilePosition PuzzleToSolve 0) )=
);;
)while
(= ElapsedTime (ElapsedTimeSeconds))
(critical SerialPrint 1
(;; (PAR:PutConsole (. `Solution found of length '))
(PAR:PutConsoleNatural Solution:Score) (PAR:PutConsole (. `: '))
(iterate (= PathScanP Solution:Path)
(~= PathScanP EmptyPath)
(= PathScanP PathScanP:Next)
(;; (PAR:PutConsoleNatural (coerce natural PathScanP:Move)) (PAR:PutConsoleSpace)
);;
)iterate
(PAR:PutConsoleNewline)
(PAR:PutConsole (. `Total solution time in seconds: ')) (PAR:PutConsoleNatural ElapsedTime) (PAR:PutConsoleNewline)
);;
)critical
);;
)local
)action
)define

The little book of semaphores which is freely available book has lots of synchronization puzzles. It includes almost all the puzzles cited in other answers. Solutions are provided for all the puzzles.

Related

NLP with Racket

I am studying NLP with Racket and Dr. Racket.
I am working with this code:
#lang racket
(define english-1
'((Initial (1))
(Final (9))
(From 1 to 3 by NP)
(From 1 to 2 by DET)
(From 2 to 3 by N)
(From 3 to 4 by BV)
(From 4 to 5 by ADV)
(From 4 to 5 by |#|)
(From 5 to 6 by DET)
(From 5 to 7 by DET)
(From 5 to 8 by |#|)
(From 6 to 7 by ADJ)
(From 6 to 6 by MOD)
(From 7 to 9 by N)
(From 8 to 8 by MOD)
(From 8 to 9 by ADJ)
(From 9 to 4 by CNJ)
(From 9 to 1 by CNJ)))
(define (getf x y)
(if (eq? (car x) y)
(cadr x)
(getf (cdr x) y)))
(define (initial-nodes network)
(list-ref (assoc 'Initial network) 1))
(define (final-nodes network)
(list-ref (assoc 'Final network) 1))
(define (transitions network)
(filter (lambda (x) (eq? (car x) 'From)) network))
(define (trans-node transition)
(getf transition 'From))
(define(trans-newnode transition)
(getf transition 'to))
(define (trans-label transition)
(getf transition 'by))
(define abbreviations
'((NP kim sandy lee)
(DET a the her)
(N consumer man woman)
(BV is was)
(CNJ and or)
(ADJ happy stupid)
(MOD very)
(ADV often always sometimes)))
(define (recognize network tape)
;; returns t if sucessfully recognizes tape - nil otherwise
(call/cc (lambda (return)
(define (recognize-next node tape network)
(if (and (null? tape) (member node (final-nodes network)))
(return #t) ; success
(for ([transition (transitions network)])
;; try each transition of the network
(when (equal? node (trans-node transition)) ; if it starts at the right node
(for ([newtape (recognize-move (trans-label transition) tape)])
;; try each possible new value of tape
(recognize-next (trans-newnode transition) newtape network))))))
(for ([initialnode (initial-nodes network)])
(recognize-next initialnode tape network))
null))) ; failed to recognize
(define (recognize-move label tape)
(if (or (eq? label (car tape))
(member (car tape) (assoc label abbreviations)))
(list (cdr tape))
(if (eq? label '|#|)
(list tape)
null)))
(require racket/trace)
(trace recognize-move)
(recognize-move english-1 '(hahaha))
The code seems to be mostly fine. However, I keep getting a error messaging related to the recognize-move function:
member: not a proper list: #f
And I thought I was dealing with lists... How can I solve this?
The problem is with this form:
(member (car tape) (assoc label abbreviations))
If assoc does not find anything the result is #f. (member 'anything #f) will not work. In Common Lisp false is the same as an empty list so member on false will work, but not in Scheme. You can perhaps make sure it's a list like this:
(member (car tape) (or (assoc label abbreviations) '()))
This is code translated from Common Lisp. In CL, nil is false and is also the empty list, (). In Racket, #f is false and is not the same as (). assoc wants to return false if it does not find a match: because of the way CL puns on false and the empty list, this means that (member ... (assoc ...)) will always work. In Racket it won't: you need to check to see if assoc failed to find a match.

How to reduce long execution time in an A* search for 8-puzzle

I'm trying to implement heuristic search strategy A* to the puzzle "8-puzzle" in Lisp.
To run my search I use the command:
(run-best '(0 1 2 3 4 5 6 B 7) '(0 1 2 3 4 5 6 7 B))
Where the first state is the start goal and the second is the end goal.
However, I end up with my program running for a long time. Eventually, I assume it will stack-overflow. *Edit: It does not run out of memory however it took 30 minutes, much longer then my Breadth first search.
Search algorithm code:
;;; This is one of the example programs from the textbook:
;;;
;;; Artificial Intelligence:
;;; Structures and strategies for complex problem solving
;;;
;;; by George F. Luger and William A. Stubblefield
;;;
;;; Corrections by Christopher E. Davis (chris2d#cs.unm.edu)
;;; insert-by-weight will add new child states to an ordered list of
;;; states-to-try.
(defun insert-by-weight (children sorted-list)
(cond ((null children) sorted-list)
(t (insert (car children)
(insert-by-weight (cdr children) sorted-list)))))
(defun insert (item sorted-list)
(cond ((null sorted-list) (list item))
((< (get-weight item) (get-weight (car sorted-list)))
(cons item sorted-list))
(t (cons (car sorted-list) (insert item (cdr sorted-list))))))
;;; run-best is a simple top-level "calling" function to run best-first-search
(defun run-best (start goal)
(declare (special *goal*)
(special *open*)
(special *closed*))
(setq *goal* goal)
(setq *open* (list (build-record start nil 0 (heuristic start))))
(setq *closed* nil)
(best-first))
;;; These functions handle the creation and access of (state parent)
;;; pairs.
(defun build-record (state parent depth weight)
(list state parent depth weight))
(defun get-state (state-tuple) (nth 0 state-tuple))
(defun get-parent (state-tuple) (nth 1 state-tuple))
(defun get-depth (state-tuple) (nth 2 state-tuple))
(defun get-weight (state-tuple) (nth 3 state-tuple))
(defun retrieve-by-state (state list)
(cond ((null list) nil)
((equal state (get-state (car list))) (car list))
(t (retrieve-by-state state (cdr list)))))
;; best-first defines the actual best-first search algorithm
;;; it uses "global" open and closed lists.
(defun best-first ()
(declare (special *goal*)
(special *open*)
(special *closed*)
(special *moves*))
(print "open =") (print *open*)
(print "closed =") (print *closed*)
(cond ((null *open*) nil)
(t (let ((state (car *open*)))
(setq *closed* (cons state *closed*))
(cond ((equal (get-state state) *goal*) (reverse (build-solution *goal*)))
(t (setq *open*
(insert-by-weight
(generate-descendants (get-state state)
(1+ (get-depth state))
*moves*)
(cdr *open*)))
(best-first)))))))
;;; generate-descendants produces all the descendants of a state
(defun generate-descendants (state depth moves)
(declare (special *closed*)
(special *open*))
(cond ((null moves) nil)
(t (let ((child (funcall (car moves) state))
(rest (generate-descendants state depth (cdr moves))))
(cond ((null child) rest)
((retrieve-by-state child rest) rest)
((retrieve-by-state child *open*) rest)
((retrieve-by-state child *closed*) rest)
(t (cons (build-record child state depth
(+ depth (heuristic child)))
rest)))))))
(defun build-solution (state)
(declare (special *closed*))
(cond ((null state) nil)
(t (cons state (build-solution
(get-parent
(retrieve-by-state state *closed*)))))))
Heuristic function for 8puzzle:
(defun hole (grid)
"Return integer index into GRID at which the 'hole' is located."
(position '0 grid))
(defun col (pair)
(car pair))
(defun row (pair)
(cdr pair))
(defun coords (index1)
"Transform INDEX, an integer index into the list, into an (X . Y)
coordinate pair for a 3x3 grid."
(cons (second (multiple-value-list (floor index1 3)))
(floor index1 3)))
(defun index1 (coords)
"Transform COORDS, an (X . Y) coordinate pair for a 3x3 grid, into
an integer index."
(+ (col coords)
(* 3 (row coords))))
(defun swap (a b list)
"Return a new list equivalent to LIST but with the items at indexes
A and B swapped."
(let ((new (copy-seq list)))
(setf (nth a new)
(nth b list))
(setf (nth b new)
(nth a list))
new))
(defun right1 (grid)
"Move the 'hole' on the 3x3 GRID one space to the right. If there
is no space to the right, return NIL."
(let ((hole (coords (hole grid))))
(if (= 2 (col hole))
nil
(swap (index1 hole)
(index1 (cons (1+ (col hole)) (row hole)))
grid))))
(defun left1 (grid)
"Move the 'hole' on the 3x3 GRID one space to the left. If there
is no space to the left, return NIL."
(let ((hole (coords (hole grid))))
(if (zerop (col hole))
nil
(swap (index1 hole)
(index1 (cons (1- (col hole)) (row hole)))
grid))))
(defun up (grid)
"Move the 'hole' on the 3x3 GRID one space up. If there is no space
up, return NIL."
(let ((hole (coords (hole grid))))
(if (zerop (row hole))
nil
(swap (index1 (cons (col hole) (1- (row hole))))
(index1 hole)
grid))))
(defun down (grid)
"Move the 'hole' on the 3x3 GRID one space down. If there is no
space down, return NIL."
(let ((hole (coords (hole grid))))
(if (= 2 (row hole))
nil
(swap (index1 (cons (col hole) (1+ (row hole))))
(index1 hole)
grid))))
;Moves
(setq *moves*
'(right1 left1 up down))
;heuristics for puzzle8
(defun heuristic (state)
(declare (special *goal*))
(heuristic-eval state *goal*))
(defun heuristic-eval (state goal)
(cond ((null state) 0)
((equal (car state) (car goal))
(heuristic-eval (cdr state) (cdr goal)))
(t (1+ (heuristic-eval (cdr state) (cdr goal))))))
Problems in the code:
recursion. write loops to avoid stack overflows
possibly long open and closed lists. The open and closed lists can be quite long. One operation is to check if there is a record with a certain state on the lists. I would use a hash-table to record the states and then use the table to check whether a state exists.
My version of the code
No solution:
CL-USER 220 > (time (run-best '(0 1 2 3 4 5 6 7 8)
'(0 2 1 3 4 5 6 7 8)
'(right1 left1 up down)))
Timing the evaluation of (RUN-BEST (QUOTE (0 1 2 3 4 5 6 7 8))
(QUOTE (0 2 1 3 4 5 6 7 8))
(QUOTE (RIGHT1 LEFT1 UP DOWN)))
User time = 0:01:05.620
System time = 0.220
Elapsed time = 0:01:05.749
Allocation = 115386560 bytes
22397 Page faults
NO-SOLUTION
Solution:
CL-USER 223 > (time (pprint (run-best '(2 1 5 3 4 6 0 8 7)
'(0 1 2 3 4 5 6 7 8)
'(right1 left1 up down))))
Timing the evaluation of (PPRINT (RUN-BEST (QUOTE (2 1 5 3 4 6 0 8 7))
(QUOTE (0 1 2 3 4 5 6 7 8))
(QUOTE (RIGHT1 LEFT1 UP DOWN))))
((2 1 5 3 4 6 0 8 7)
(2 1 5 0 4 6 3 8 7)
(2 1 5 4 0 6 3 8 7)
(2 0 5 4 1 6 3 8 7)
(0 2 5 4 1 6 3 8 7)
(4 2 5 0 1 6 3 8 7)
(4 2 5 1 0 6 3 8 7)
(4 2 5 1 6 0 3 8 7)
(4 2 5 1 6 7 3 8 0)
(4 2 5 1 6 7 3 0 8)
(4 2 5 1 0 7 3 6 8)
(4 2 5 1 7 0 3 6 8)
(4 2 0 1 7 5 3 6 8)
(4 0 2 1 7 5 3 6 8)
(0 4 2 1 7 5 3 6 8)
(1 4 2 0 7 5 3 6 8)
(1 4 2 3 7 5 0 6 8)
(1 4 2 3 7 5 6 0 8)
(1 4 2 3 0 5 6 7 8)
(1 0 2 3 4 5 6 7 8)
(0 1 2 3 4 5 6 7 8))
User time = 0.115
System time = 0.001
Elapsed time = 0.103
Allocation = 2439744 bytes
194 Page faults
Try the memoize utility. You can find a related question here (How do I memoize a recursive function in Lisp?).
Memoize keeps track of the calls made to any memoized function and immediately returns any known (previously calculated) results to avoid recalculating them. The results in the case of a recursive function like yours are spectacular.

Tail call optimization in Racket

I was doing SICP exercise 2.28 and stumbled upon a strange behaviour of the following code:
(define (fringe tree)
(cond
((null? tree) '())
((not (pair? tree)) (list tree))
(else (append (fringe (car tree)) (fringe (cdr tree))))))
(define (fringe-tail tree)
(define (fringe-iter tree result)
(cond
((null? tree) result)
((not (pair? tree)) (list tree))
(else (fringe-iter (cdr tree) (append result (fringe-tail (car tree)))))))
(fringe-iter tree '()))
(define x (make-list (expt 10 4) 4))
(time (fringe x))
(time (fringe-tail x))
Ordinary fringe runs much faster than its iterative version fringe-tail:
cpu time: 4 real time: 2 gc time: 0
vs.
cpu time: 1063 real time: 1071 gc time: 191
It looks like fringe was optimized into loop and avoids any allocations, while fringe-tail runs much slower and spends time creating and destroying objects.
Can anyone explain this to me?
(Just in case I'm using racket 5.2.1)
If you replace the last clause with:
(else (fringe-iter (cdr tree) (append (fringe-tail (car tree)) result)))
then they run at the same speed for that input, and the tail-recursive version is faster for larger input.
The problem is that you're appending the much longer list for the cdr on to the front, which traverses and allocates much more than the naive version, which appends the fringe of the car on to the front.
The given code has applications in non-tail position, so the function is not iterative, despite its name. :)
Try this:
(define (fringe-tail tree)
(define (iter tree k)
(cond
[(null? tree)
(k '())]
[(not (pair? tree))
(k (list tree))]
[else
(iter (car tree)
(lambda (v1)
(iter (cdr tree)
(lambda (v2)
(k (append v1 v2))))))]))
(iter tree (lambda (a-fringe) a-fringe)))
However, it still uses append which is as expensive as the length of its first argument. Certain degenerate inputs into fringe and fringe-tail will cause a lot of computational suffering.
Let's give an example of such degenerate inputs:
(define (build-evil-struct n)
(if (= n 0)
(list 0)
(list (list (build-evil-struct (sub1 n)))
(build-evil-struct (sub1 n))
(list n))))
(define evil-struct (build-evil-struct 20))
When applied to both fringe and fringe-iter, you'll see very bad performance: I observe seconds of compute time on my own system for fringe and fringe-tail. These tests were run under DrRacket with debugging disabled. If you enable debugging, your numbers will be significantly different.
> (time (void (fringe evil-struct)))
cpu time: 2600 real time: 2602 gc time: 1212
> (time (void (fringe-tail evil-struct)))
cpu time: 4156 real time: 4155 gc time: 2740
With both of these, the use of append is what makes these susceptible to certain degenerate inputs. If we write an accumulating version of fringe, we can eliminate that cost, since we then get to use the constant-time cons operation:
(define (fringe/acc tree)
(define (iter tree acc)
(cond [(null? tree)
acc]
[(not (pair? tree))
(cons tree acc)]
[else
(iter (car tree) (iter (cdr tree) acc))]))
(iter tree '()))
Let's look at the performance of fringe/acc on this structure:
> (time (void (fringe/acc evil-struct)))
cpu time: 272 real time: 274 gc time: 92
Much better! And it's a straightforward matter to turn all the calls here to tail calls.
(define (fringe/acc/tail tree)
(define (iter tree acc k)
(cond [(null? tree)
(k acc)]
[(not (pair? tree))
(k (cons tree acc))]
[else
(iter (cdr tree) acc
(lambda (v1)
(iter (car tree) v1 k)))]))
(iter tree '() (lambda (v) v)))
> (time (void (fringe/acc/tail evil-struct)))
cpu time: 488 real time: 488 gc time: 280
Racket's implementation of the stack is, in this particular case, a bit faster than our reified stack we're representing in the continuations, so fringe/acc is faster than fringe/acc/tail. Still, both of these are significantly better than fringe because they avoid append.
All this being said: this function is already built-into Racket as the flatten function! So you might as well just use that if you don't want to reinvent the wheel. :)

Does Lisp have something like Haskell's takeWhile function?

I'm new to Common Lisp. In Haskell, you can do a little something like this:
Prelude> takeWhile (<= 10) [k | k <- [1..]]
[1,2,3,4,5,6,7,8,9,10]
Is this possible in Lisp? Not necessarily with an infinite list, but with any list.
You could use LOOP:
(setq *l1* (loop for x from 1 to 100 collect x))
(loop for x in *l1* while (<= x 10) collect x)
If you really need it as a separate function:
(defun take-while (pred list)
(loop for x in list
while (funcall pred x)
collect x))
And here we are:
T1> (take-while (lambda (x) (<= x 10)) *l1*)
(1 2 3 4 5 6 7 8 9 10)
But if we compare:
(loop for x in *l1* while (<= x 10) collect x)
(take-while (lambda (x) (<= x 10)) *l1*)
I think I would just stick with loop.
For infinite sequences, you could take a look at Series:
T1> (setq *print-length* 20)
20
T1> (setq *l1* (scan-range :from 1))
#Z(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 ...)
T1> (until-if (lambda (x) (> x 10)) *l1*)
#Z(1 2 3 4 5 6 7 8 9 10)
This should do...
(defun take-while (list test)
(and list (funcall test (car list))
(cons (car list) (take-while (cdr list) test))))
(take-while '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) (lambda (x) (< x 10)))
--> (1 2 3 4 5 6 7 8 9)
However this "natural" implementation is not tail-recursive and could crash for big lists.
An explicit push-nreverse approach (a common pattern) could be
(defun take-while (list test)
(do ((res nil))
((or (null list) (not (funcall test (car list))))
(nreverse res))
(push (car list) res)
(setf list (cdr list))))
A recursive (but tail-recursive, therefore probably ok with most CL implementations) could IMO be the following:
(defun take-while (list test)
(labels ((rec (res x)
(if (and x (funcall test (car x)))
(rec (cons (car x) res) (cdr x))
(nreverse res))))
(rec nil list)))
Note that however it's not guaranteed that a common lisp implementation will handle tail-call optimizations.
The CL-LAZY library implements lazy calling for Common Lisp and provides a take-while function that is laziness aware. You can install it with Quicklisp and try it out.
Some languages provide a Haskell-style list API as 3rd party libraries, with or without support for infinite streams.
Some examples:
Clojure's sequences: take-while
Scala has something
Remember that takeWhile is relatively easy to implement over a sequence, and is given in Haskell as:
takeWhile _ [] = []
takeWhile p (x:xs)
| p x = x : takeWhile p xs
| otherwise = []
You can have a lazy evaluation in common lisp using closures (from Paul Graham's On Lisp):
(defun lazy-right-fold (comb &optional base)
"Lazy right fold on lists."
(labels ((rec (lst)
(if (null lst)
base
(funcall comb
(car lst)
#'(lambda () (rec (cdr lst)))))))
#'rec))
Then, take-while becomes:
(defun take-while (pred lst)
(lazy-right-fold #'(lambda (x f) (
(if (test x)
(cons x (funcall f))
(funcall f)))
nil))

Which amount of code execution should I parallelize?

If I want to parallelize the execution of an algorithm what are the smalls chunks of code that I should split?
A classic example is a sorting algorithm. For what element size or typical execution time does it make sense to split the sorting between multiple threads? Or when is the overhead for waiting on another thread larger than the execution time on a single thread?
Are there any simple rules? Does this depend on the OS?
The key rule is "fork only when the forking overhead is much smaller than the amount of work the fork will do". Since forking overhead is a property of the specific technology you use, and so is the effort to do the work, you in some sense have to determine this empirically. You'll likely end up with some threshold tuning constant in your code to represent this tradeoff.
What you will discover in practice is that finding seperable chunks of work is actually hard. If you make the work chunk small, it hasn't got a lot of dependencies and you can schedule it once all its input dataflows are ready. But small chunks usually mean small work, and the forking overhead usually negates the gain. If you try to make the chunks big, they have so many dependences that you can't break them out to schedule them.
Some people are lucky and can find such big chunks; we call most of those people physicists and/or Fortran programmers and they are taking advantage of data parallelism induced by dividing the world into as many tiny pieces as they can.
The only decent cure I know of is to use a spectacularly fast forking mechanism, so that you can find the smallest practical chunks. Unfortunately, the parallelism libraries offered to do this are ... libraries, invoked dynamically, with corresponding dynamic invocation overhead. Typical libraries containing parallelism primitives takes 100s to thousands of cycles to implement a "fork"; this is bad news if your chunk of work is 100 machine instructions.
I believe strongly that to get such fast forking mechanisms, the language compiler has to know that you are doing the fork, e.g., "fork" (however spelled :-) has be a keyword in the language. Then the compiler can see the forks, and preallocate everything needed to minimize the time to accomplish this, and generate special code to manage the forking (and joining) steps.
The PARLANSE language that I designed, and that we use at Semantic Designs is one such language.
It is a Lisp-like language in syntax (but not in semantics). Its parallelism operator is spelled "(|| ... )". You can see it below in the Quicksort module we use daily, below.
You can also see the explicit QuickSortParallelThreshold value, determined empirically.
This Quicksort scales linearly to 8 cores on an Intel x86 system.
(define QuickSort
(module
(;; (define Value nu)
(compileifthen (~ (defined QuickSortWithParlanseBuiltInOrderingOfNu))
(define QuickSortWithParlanseBuiltInOrderingOfNu ~f) ; use PARLANSE comparison operators
)compileifthen
(compileifthen (~ (defined QuickSortParallelThreshold))
(define QuickSortParallelThreshold 100)
)compileifthen
(compileifthen (~ (defined QuickSortThreshold))
(compileifthenelse QuickSortWithParlanseBuiltInOrderingOfNu
(define QuickSortThreshold 16)
(define QuickSortThreshold 8)
)compileifthenelse
)compileifthen
(compileifthenelse (~ (defined QuickSortWithCompareByReference))
(define QuickSortWithCompareByReference ~f)
(compileifthen QuickSortWithParlanseBuiltInOrderingOfNu
(define QuickSortWithCompareByReference ~f)
)compileifthen
)compileifthenelse
(define SortRange
(action (procedure (structure (compileifthen (~ QuickSortWithParlanseBuiltInOrderingOfNu)
(compileifthenelse (~ QuickSortWithCompareByReference)
[compare (function (sort integer (range -1 +1)) (structure [value1 Value] [value2 Value]))]
[compare (function (sort integer (range -1 +1)) (structure [value1 (reference Value)] [value2 (reference Value)]))]
)compileifthenelse
)compileifthen
[a (reference (array Value 1 dynamic))]
[from natural]
[to natural]
)structure
)procedure
(local (;; (define quicksort
(action (procedure (structure [l integer] [r integer])))
)define
(define quicksort
(action (procedure (structure [l integer] [r integer]))
(ifthenelse (<= (- r l) (coerce integer QuickSortThreshold))
(do [i integer] (++ l) r +1
(local (= [exch Value] a:i)
(block exit_if_inserted
(;; (do [j integer] (-- i) l -1
(ifthenelse (compileifthenelse QuickSortWithParlanseBuiltInOrderingOfNu
(> a:j exch)
(compileifthenelse (~ QuickSortWithCompareByReference)
(== (compare a:j exch) +1)
(== (compare (. a:j) (. exch)) +1)
)compileifthenelse
)compileifthenelse
(= a:(++ j) a:j)
(;; (= a:(++ j) exch)
(exitblock exit_if_inserted)
);;
)ifthenelse
)do
(= a:l exch)
);;
)block
)local
)do
(local (;; (= [i integer] l)
(= [j integer] r)
(= [p integer] l)
(= [q integer] r)
[exch Value]
);;
(;;
`use middle element as pivot':
(local (= [m integer] (// (+ l r) +2))
(;; (= exch a:m)
(= a:m a:r)
(= a:r exch)
);;
)local
`4-way partitioning = < > =':
(loop exit_if_partitioned
(;;
`find element greater than pivot':
(loop exit_if_greater_than_found
(;; (compileifthenelse QuickSortWithParlanseBuiltInOrderingOfNu
(ifthenelse (< a:i a:r)
(consume ~t)
(ifthenelse (> a:i a:r)
(exitblock exit_if_greater_than_found)
(;; (ifthen (>= i j)
(exitblock exit_if_partitioned)
)ifthen
(= exch a:p)
(= a:p a:i)
(= a:i exch)
(+= p 1)
);;
)ifthenelse
)ifthenelse
(case (compileifthenelse (~ QuickSortWithCompareByReference)
(compare a:i a:r)
(compare (. a:i) (. a:r))
)compileifthenelse
-1
(consume ~t)
+1
(exitblock exit_if_greater_than_found)
else (;; (ifthen (>= i j)
(exitblock exit_if_partitioned)
)ifthen
(= exch a:p)
(= a:p a:i)
(= a:i exch)
(+= p 1)
);;
)case
)compileifthenelse
(+= i 1)
);;
)loop
`find element less than to pivot':
(loop exit_if_less_than_found
(;; (-= j 1)
(ifthen (>= i j)
(exitblock exit_if_partitioned)
)ifthen
(compileifthenelse QuickSortWithParlanseBuiltInOrderingOfNu
(ifthenelse (< a:j a:r)
(exitblock exit_if_less_than_found)
(ifthenelse (> a:j a:r)
(consume ~t)
(;; (-= q 1)
(= exch a:j)
(= a:j a:q)
(= a:q exch)
);;
)ifthenelse
)ifthenelse
(case (compileifthenelse (~ QuickSortWithCompareByReference)
(compare a:j a:r)
(compare (. a:j) (. a:r))
)compileifthenelse
-1
(exitblock exit_if_less_than_found)
+1
(consume ~t)
else (;; (-= q 1)
(= exch a:j)
(= a:j a:q)
(= a:q exch)
);;
)case
)compileifthenelse
);;
)loop
`move found elements to proper partitions':
(;; (= exch a:i)
(= a:i a:j)
(= a:j exch)
);;
`increment index':
(+= i 1)
);;
)loop
`3-way partitioning < = >':
(;;
`move pivot to final location':
(;; (= exch a:i)
(= a:i a:r)
(= a:r exch)
(= j (-- i))
(= i (++ i))
);;
`move elements equal to pivot to final locations':
(;; (do [k integer] l (-- p) +1
(;; (= exch a:k)
(= a:k a:j)
(= a:j exch)
(-= j 1)
);;
)do
(do [k integer] (-- r) q -1
(;; (= exch a:i)
(= a:i a:k)
(= a:k exch)
(+= i 1)
);;
)do
);;
);;
`sort partitions not equal to pivot':
(ifthenelse (<= (- r l) (coerce integer QuickSortParallelThreshold))
(;; (quicksort l j)
(quicksort i r)
);;
(|| (quicksort l j)
(quicksort i r)
)||
)ifthenelse
);;
)local
)ifthenelse
)action
)define
);;
(;; (quicksort (coerce integer from) (coerce integer to))
(ifdebug (do [i integer] (coerce integer from) (-- (coerce integer to)) +1
(trust (compileifthenelse QuickSortWithParlanseBuiltInOrderingOfNu
(<= a:i a:(++ i))
(compileifthenelse (~ QuickSortWithCompareByReference)
(<= (compare a:i a:(++ i)) +0)
(<= (compare (. a:i) (. a:(++ i))) +0)
)compileifthenelse
)compileifthenelse
`QuickSort:Sort -> The array is not sorted.'
)trust
)do
)ifdebug
);;
)local
)action
)define
(define Sort
(action (procedure (structure (compileifthen (~ QuickSortWithParlanseBuiltInOrderingOfNu)
(compileifthenelse (~ QuickSortWithCompareByReference)
[compare (function (sort integer (range -1 +1)) (structure [value1 Value] [value2 Value]))]
[compare (function (sort integer (range -1 +1)) (structure [value1 (reference Value)] [value2 (reference Value)]))]
)compileifthenelse
)compileifthen
[a (reference (array Value 1 dynamic))]
)structure
)procedure
(compileifthenelse (~ QuickSortWithParlanseBuiltInOrderingOfNu)
(SortRange compare a (coerce natural (lowerbound (# a) 1)) (coerce natural (upperbound (# a) 1)))
(SortRange a (coerce natural (lowerbound (# a) 1)) (coerce natural (upperbound (# a) 1)))
)compileifthenelse
)action
)define
);;
)module
)define
It depends on the overhead of the inter-thread communication. I tested openMP with image processing, and there a line of pixels was convenient, as well giving good speedups. My image was a megapixel, so there were 1000 tasks, which is probably more than enough to keep today's manycore machines busy. You also don't need to limit yourself to jobs that take more than a second or so. In this example the speedups of jobs of the order of 10 milliseconds where clearly visible.
Now this was a pleasant algorithm because it was not recursive, so there were no dependencies of one task on the other, and all the tasks were automatically the same size.
Sorting algorithms will be harder, due to varying task sizes. You'd want to be able to experiment with this, and maybe choose a sort that is easier to paralellize.
Take couple of courses in concurrent and parallel programming. Learn several technologies like plain old fork & forget or "manual" multithreading (Java threads or pthreads), MPI, OpenMP, BSP, maybe even CUDA or OpenCL. Then either decide to be an expert or let the experts design and implement efficient and correct parallel algorithms. The "parallel" part is easy, the "efficient" and "correct" parts are not, when both are needed. Even Java concurrent Vector collection, designed and implemented by experts, was not free from bugs in the first versions. The mere definition of memory model was not clear in the first versions of Java standard!
The simplest rule: use ready-to-use components designed and implemented by experts and don't try to achieve both correctness and efficiency designing your own parallel algorithms unless you're an expert.
Solving this problem programmatically is one of the holy grails of parallel computing, and there are many libraries that can approximate the optimal parallelism for particular problems (e.g., Data Parallel Haskell).
Anyhow, to do this by hand, you need to understand:
The algorithm that you wish to parallelize (Is it parallelizable?)
The characteristics of the data, e.g., sizes, location (on disk, in memory), etc.
The hardware that you're running on, e.g., number cores, memory latency, cache sizes/lines/associavity, etc.
The threading model of both the implementation language (coroutines, green threads, OS threads) and OS.
Cost of spawning and context-switching between threads.
Assuming that the algorithm is parallelizable, your goal is to find the number of threads and the relative chunk size of the data, such that you can make optimal use of the hardware to generate a solution.
This is quite hard to do without lots of experimentation. My preferred way of figuring this out is by running lots of benchmarks, and getting performance data as a function of one or more combinations of the following:
Number of threads.
Buffer sizes (if the data is not in RAM) incrementing at some reasonable value (e.g., block size, packet size, cache size, etc.)
Varying chunk sizes (if you can process the data incrementally).
Various tuning knobs for the OS or language runtime.
Pinning threads to CPUs to improve locality.
Etc.
Anyhow, this is no easy task, and there are tools and libraries to help you squeeze as much performance as is possible out of your parallelizable problems. The only reasonable way you can do this correctly by having a good understanding of your data, your code, and your runtime environment.

Resources