Wednesday, September 14, 2011

N Queens Join the Party

We are continuing to work on the ParaSail compiler. Our latest program to compile and run is a parallel but non-recursive version of a solution to the "N Queens" problem. There is an N_Queens module, with a nested Solution_State module used to represent a partial solution. The algorithm starts at column 1 and works toward column N, branching into parallel threads to evaluate each possibility for the next row, and when finding an acceptable one, circling back to the outer loop to march onto the next column. There is a simple Test_N_Queens func at the bottom.  Below that is the result of running the program.

Enjoy!

interface N_Queens <N : Univ_Integer := 8> is
    // Place N queens on an NxN checkerboard so that none of them can
    // "take" each other.
    type Chess_Unit is new Integer_Range<-100 .. 100>;
        // An integer type sufficiently big to represent values -100 to +100
    const Rows : Range<Chess_Unit> := 1..N;
    const Columns : Range<Chess_Unit> := 1..N;
    type Row is Chess_Unit {Row in Rows};  // A subrange in 1..N
    type Column is Chess_Unit {Column in Columns};  // A subrange in 1..N
    type Solution is Array<optional Column, Row>;  
      // A "solution" is an array of Column's, indexed by "Row."
      // It indicates in which Column a queen of the given Row is located
      // An example solution would be:  2 8 6 1 3 5 7 4
      //   meaning that the queen in row 1 is at column 2,
      //   the queen in row 2 is at column 8, the queen in
      //   row 3 is at column 6, and so on.
     
    func Place_Queens() -> Vector<Solution> 
      {for all Sol of Place_Queens => for all Col of Sol => Col not null};
        // Produce a vector of solutions, with the requirement
        // that for each solution, there are non-null column numbers
        // specified for each row of the checkerboard.
end interface N_Queens;

class N_Queens is
    type Sum_Range is Chess_Unit {Sum_Range in 2..2*N};
        // Sum_Range is used for diagonals where the row+column is the
        // same throughout the diagonal.
    type Diff_Range is Chess_Unit {Diff_Range in (1-N) .. (N-1)};
        // Diff_Range is used for diagonals where row-column is the
        // same throughout the diagonal.
    type Sum is Countable_Set<Sum_Range>;
        // This type of set keeps track of which Sum_Range diagonals
        // have a queen on them already.
    type Diff is Countable_Set<Diff_Range>;
        // This type of set keeps track of which Diff_Range diagonals
        // have a queen on them already.

    interface Solution_State<> is
        // We build up a solution state progressively as we move
        // across the checkerboard, one column at a time.
        func Initial_State() -> Solution_State;
        func Is_Acceptable(S : Solution_State; R : Row) -> Boolean;
          // Is_Acceptable returns True if the next queen could be
          // place in row R.
        func Current_Column(S : Solution_State) -> Column;
          // Current_Column indicates which column we are working on.
        func Next_State(S : Solution_State; R : Row) -> Solution_State;
          // Next_State returns a Solution_State produced by
          // adding a queen at (Current_Column(S), R).
        func Final_Result(S : Solution_State; R : Row) -> Solution;
          // Final_Result returns a result produced by adding a queen
          // at (Columns.Last, R) to a solution with all other columns
          // placed.
    end interface Solution_State;

    class Solution_State is
        const C : Column;    // Current column
        const Trial : Solution;  // Trial solution, some col#s still null
        const Diag_Sum : Sum;   // Set of "sum" diagonals in use
        const Diag_Diff : Diff; // Set of "diff" diagnoals in use
      exports
        func Initial_State() -> Solution_State is
            return (C => 1, Trial => Create(Rows, null), 
              Diag_Sum => [], Diag_Diff => []);
        end func Initial_State;

        func Is_Acceptable(S : Solution_State; R : Row) -> Boolean is
          // Is_Acceptable returns True if the next queen could be
          // place in row R.
            return S.Trial[R] is null and then
              (R+S.C) not in S.Diag_Sum and then 
              (R-S.C) not in S.Diag_Diff;
        end func Is_Acceptable;
        
        func Current_Column(S : Solution_State) -> Column is
          // Current_Column indicates which column we are working on.
            return S.C;
        end func Current_Column;

        func Next_State(S : Solution_State; R : Row) -> Solution_State is
          // Next_State returns a Solution_State produced by
          // adding a queen at (Current_Column(S), R).
            return (C => S.C+1, 
              Trial     => S.Trial | [R => S.C],
              Diag_Sum  => S.Diag_Sum | (R+S.C),
              Diag_Diff => S.Diag_Diff | (R-S.C));
        end func Next_State;

        func Final_Result(S : Solution_State; R : Row) -> Solution is
          // Final_Result returns a result produced by adding a queen
          // at (Columns.Last, R) to a solution with all other columns
          // placed.
            return S.Trial | [R => S.C];
        end func Final_Result;

    end class Solution_State;

  exports
    func Place_Queens() -> Vector<Solution> 
      {for all Sol of Place_Queens => for all Col of Sol => Col not null}
        // Produce a vector of solutions, with the requirement
        // that for each solution, there are non-null column numbers
        // specified for each row of the checkerboard.
    is
      var Solutions : concurrent Vector<Solution> := [];
      
     *Outer_Loop*
      for State : Solution_State := Initial_State() loop
          // Iterate over the columns
        
          for R in Rows concurrent loop
              // Iterate over the rows
              if Is_Acceptable(State, R) then
                  // Found a Row/Column combination that is not on any diagonal
                  // already occupied.
                  if Current_Column(State) < N then
                      // Keep going since haven't reached Nth column.
                      continue loop Outer_Loop with Next_State(State, R);
                  else
                      // All done, remember trial result with last queen placed
                      Solutions |= Final_Result(State, R); 
                  end if;
              end if;
          end loop;
      end loop Outer_Loop;
      return Solutions;
      
    end func Place_Queens;
end class N_Queens;

func Test_N_Queens() is
    type Eight_Queens is N_Queens<8>;
    var Results := Eight_Queens::Place_Queens();
    Println("Number of results = " | Length(Results));
    for I in 1..Length(Results) forward loop
        const Result := Results[I];
        Print("Result #" | I);
        for J in 1..Length(Result) forward loop
            Print(" " | [[Result[J]]]);
        end loop;
        Print('\n');
    end loop;
end func Test_N_Queens;

Here is the result of running Test_N_Queens, which is set up to solve the 8-queens problem. It has also been verified to work with 4 queens (2 solutions), 5 queens (10 solutions), and 9 queens (352 solutions). After "quit"ing, a display of threading statistics is provided.

Parsing aaa.psi
Parsing n_queens4.psl
---- Beginning semantic analysis ----
 58 trees in library.
Done with First pass.
Done with Second pass.
Done with Pre codegen pass.
Done with Code gen.

Command to execute: Test_N_Queens

Number of results = 92
Result #1 4 2 5 8 6 1 3 7
Result #2 1 7 4 6 8 2 5 3
Result #3 4 2 8 5 7 1 3 6
Result #4 1 5 8 6 3 7 2 4
Result #5 4 1 5 8 6 3 7 2
Result #6 2 7 3 6 8 5 1 4
Result #7 7 1 3 8 6 4 2 5
Result #8 5 2 4 6 8 3 1 7
Result #9 5 7 1 3 8 6 4 2
Result #10 5 1 8 6 3 7 2 4
Result #11 1 6 8 3 7 4 2 5
Result #12 4 2 7 3 6 8 1 5
Result #13 3 1 7 5 8 2 4 6
Result #14 3 6 2 7 5 1 8 4
Result #15 5 1 4 6 8 2 7 3
Result #16 6 4 2 8 5 7 1 3
Result #17 3 6 2 5 8 1 7 4
Result #18 1 7 5 8 2 4 6 3
Result #19 3 7 2 8 5 1 4 6
Result #20 2 6 1 7 4 8 3 5
Result #21 3 7 2 8 6 4 1 5
Result #22 4 6 8 2 7 1 3 5
Result #23 4 1 5 8 2 7 3 6
Result #24 7 4 2 8 6 1 3 5
Result #25 3 6 8 2 4 1 7 5
Result #26 5 1 8 4 2 7 3 6
Result #27 7 4 2 5 8 1 3 6
Result #28 4 7 5 2 6 1 3 8
Result #29 7 3 8 2 5 1 6 4
Result #30 5 7 2 6 3 1 8 4
Result #31 5 7 2 4 8 1 3 6
Result #32 4 7 3 8 2 5 1 6
Result #33 4 7 1 8 5 2 6 3
Result #34 7 3 1 6 8 5 2 4
Result #35 6 3 7 2 8 5 1 4
Result #36 6 1 5 2 8 3 7 4
Result #37 4 8 1 5 7 2 6 3
Result #38 6 3 1 7 5 8 2 4
Result #39 6 3 7 2 4 8 1 5
Result #40 6 4 1 5 8 2 7 3
Result #41 5 7 2 6 3 1 4 8
Result #42 5 7 1 4 2 8 6 3
Result #43 3 5 2 8 1 7 4 6
Result #44 4 6 1 5 2 8 3 7
Result #45 2 7 5 8 1 4 6 3
Result #46 5 3 1 6 8 2 4 7
Result #47 4 2 7 5 1 8 6 3
Result #48 6 3 1 8 5 2 4 7
Result #49 3 8 4 7 1 6 2 5
Result #50 6 8 2 4 1 7 5 3
Result #51 5 3 1 7 2 8 6 4
Result #52 2 5 7 4 1 8 6 3
Result #53 3 6 2 7 1 4 8 5
Result #54 6 3 1 8 4 2 7 5
Result #55 4 2 8 6 1 3 5 7
Result #56 8 3 1 6 2 5 7 4
Result #57 3 5 8 4 1 7 2 6
Result #58 4 8 1 3 6 2 7 5
Result #59 6 3 5 8 1 4 2 7
Result #60 6 3 7 4 1 8 2 5
Result #61 8 4 1 3 6 2 7 5
Result #62 8 2 5 3 1 7 4 6
Result #63 6 3 5 7 1 4 2 8
Result #64 4 8 5 3 1 7 2 6
Result #65 7 2 6 3 1 4 8 5
Result #66 2 4 6 8 3 1 7 5
Result #67 5 2 4 7 3 8 6 1
Result #68 3 5 2 8 6 4 7 1
Result #69 4 6 8 3 1 7 5 2
Result #70 4 7 5 3 1 6 8 2
Result #71 3 6 4 2 8 5 7 1
Result #72 2 6 8 3 1 4 7 5
Result #73 5 7 4 1 3 8 6 2
Result #74 7 5 3 1 6 8 2 4
Result #75 4 2 7 3 6 8 5 1
Result #76 6 4 7 1 8 2 5 3
Result #77 5 2 6 1 7 4 8 3
Result #78 7 2 4 1 8 5 3 6
Result #79 6 2 7 1 3 5 8 4
Result #80 8 2 4 1 7 5 3 6
Result #81 3 6 8 1 5 7 2 4
Result #82 5 2 8 1 4 7 3 6
Result #83 5 3 8 4 7 1 6 2
Result #84 3 6 8 1 4 7 5 2
Result #85 5 8 4 1 7 2 6 3
Result #86 3 6 4 1 8 5 7 2
Result #87 3 5 7 1 4 2 8 6
Result #88 6 2 7 1 4 8 5 3
Result #89 6 4 7 1 3 5 2 8
Result #90 5 8 4 1 3 6 2 7
Result #91 2 5 7 1 3 8 6 4
Result #92 2 8 6 1 3 5 7 4

Command to execute: quit

Threading Statistics:
 Num_Initial_Thread_Servers : 10
 Num_Dynamically_Allocated_Thread_Servers : 0
 Max_Waiting_Threads (for server task): 74
 Max_Active : 118
 Max_Active_Masters : 133
 Max_Sub_Threads_Per_Master : 87
 Max_Waiting_For_Threads (to finish): 37171

Thursday, September 8, 2011

Another ParaSail example that compiles and runs

Here is a version of parallel Quicksort that now compiles and runs through the ParaSail compiler. This is parallel but non-recursive. It uses a parallel pair of continue loop statements rather than recursion.  It uses "slicing" on the array.  A[..] takes an array and returns a "slice" of the array that contains all elements of the array.  After partitioning the array, the code splits into two threads and then continues with a left "slice" and a right "slice" of the array.  The "<=>" operator performs a swap operation.

There is a simple Test_Sort test function at the bottom.  It uses a very simple random number generator to populate an array and then sort it (twice).

At the very bottom we have the result of running the program.
interface Sorting<Array_Type is Indexable<Comparable<>, Countable<>>> is
    func Quicksort(var A : Array_Type);
          // Sort Arr according to the sorting op "<" which returns
          // True if Left must appear before Right in the sorted order.
          // Before returns False if Left = Right.
end interface Sorting;

class Sorting is
  exports
    func Quicksort(var A : Array_Type) is
        // Handle short arrays directly.  Partition longer arrays.
        for Arr : Slice<Array_Type> => A[..] while Length(Arr) > 1 loop
            if Length(Arr) == 2 then
               if Arr[Arr.Last] < Arr[Arr.First] then
                   // Swap elements
                   Arr[Arr.First] <=> Arr[Arr.Last];
               end if;
            else
               // Partition array
               const Mid := Arr[Arr.First + Length(Arr)/2];
               var Left := Arr.First;
               var Right := Arr.Last;
               until Left > Right loop
                 var New_Left := Right+1;
                 var New_Right := Left-1;
                 block
                   // Find item in left half to swap
                   for I in Left .. Right forward loop
                       if not (Arr[I] < Mid) then
                           // Found an item that can go into right partitition
                           New_Left := I;
                           if Mid < Arr[I] then
                               // Found an item that *must* go into right part
                               exit loop;
                           end if;
                       end if;
                   end loop;
                 ||  
                   // Find item in right half to swap
                   for J in Left .. Right reverse loop
                       if not (Mid < Arr[J]) then
                           // Found an item that can go into left partitition
                           New_Right := J;
                           if Arr[J] < Mid then
                               // Found an item that *must* go into left part
                               exit loop;
                           end if;
                       end if;
                   end loop;
                 end block;
                 
                 if New_Left > New_Right then
                     // Nothing more to swap
                     // Exit loop and recurse on two partitions
                     Left := New_Left;
                     Right := New_Right;
                     exit loop;
                 end if;
                 
                 // Swap items
                 Arr[New_Left] <=> Arr[New_Right];
                 
                 // continue looking for items to swap
                 Left := New_Left + 1;
                 Right := New_Right - 1;
               end loop;
               
               // At this point, "Right" is right end of left partition
               // and "Left" is left end of right partition
               // and the partitions don't overlap
               // and neither is the whole array
               // and everything in the left partition can precede Mid
               // and everything in the right partition can follow Mid
               // and everything between the partitions is equal to Mid.
               {Left > Right;
                Right < Arr.Last;
                Left > Arr.First;
                (for all I in Arr.First .. Right => not (Mid < Arr[I]));
                (for all J in Left .. Arr.Last => not (Arr[J] < Mid));
                (for all K in Right+1 .. Left-1 => 
                  not (Mid < Arr[K]) and not (Arr[K] < Mid))}
               
             then
               // continue with two halves in parallel
               continue loop with Arr[Arr.First .. Right];
             ||
               continue loop with Arr[Left .. Arr.Last];
            end if;
        end loop;
   end func Quicksort;
end class Sorting;

func Random(var Seed : Univ_Integer; Mult, Mod : Univ_Integer) 
  -> Univ_Integer is
    Seed := Seed * Mult mod Mod;
    return Seed;
end func Random;

func Test_Sort(Len : Univ_Integer) is
    // For Random
    const Mult := 7**5;
    const Mod := 2**31 - 1;
    var Seed := Len;
    Println("Seed = " | Seed | ", Mult = " | Mult | ", Mod = " | Mod);

    type My_Sorter is Sorting<Vector<Univ_Integer>>;
    var Vec : Vector<Univ_Integer> := [];

    for I in 1..Len loop
        Vec |= Random(Seed, Mult, Mod) mod 100;
    end loop;

    var Vec2 := Vec;

    Println("Before sort, Vec = ");
    for I in 1 .. Length(Vec) forward loop
        Print(" " | Vec[I]);
        if I < Length(Vec) then
            Print(",");
        end if;
    end loop;
    Print("\n");

    My_Sorter::Quicksort(Vec);

    Println("After sort, Vec = ");
    for I in 1 .. Length(Vec) forward loop
        Print(" " | Vec[I]);
        if I < Length(Vec) then
            Print(",");
        end if;
    end loop;
    Print("\n");

    My_Sorter::Quicksort(Vec2);

    Println("After 2nd sort, Vec2 = ");
    for I in 1 .. Length(Vec2) forward loop
        Print(" " | Vec2[I]);
        if I < Length(Vec2) then
            Print(",");
        end if;
    end loop;
    Print("\n");

end func Test_Sort;
Here is the result of compiling and running the program. "aaa.psi" contains the standard ParaSail library of modules. "qsort6.psl" is given above. We are using the compiler interactively here, so we can run stand-alone ParaSail operations. It also can run non-interactively, by giving "-command <operation> <param1> ..." after the list of source file names on the command line. When in interactive mode, it dumps out some virtual machine threading statistics after the user "quit"s. These are at the very bottom. In this example, we have 21 threads active simultaneously at one point during execution.
% pslc aaa.psi qsort6.psl
Parsing aaa.psi
Parsing qsort6.psl
---- Beginning semantic analysis ----
 52 trees in library.
Done with First pass.
Done with Second pass.
Done with Pre codegen pass.
Done with Code gen.
Command to execute: Test_Sort 20

Seed = 20, Mult = 16807, Mod = 2147483647
Before sort, Vec = 
 40, 86, 55, 37, 30, 52, 80, 49, 49, 34, 71, 30, 88, 40, 93, 90, 29, 80, 71, 93
After sort, Vec = 
 29, 30, 30, 34, 37, 40, 40, 49, 49, 52, 55, 71, 71, 80, 80, 86, 88, 90, 93, 93
After 2nd sort, Vec2 = 
 29, 30, 30, 34, 37, 40, 40, 49, 49, 52, 55, 71, 71, 80, 80, 86, 88, 90, 93, 93
Command to execute: quit

Threading Statistics:
 Num_Initial_Thread_Servers : 10
 Num_Dynamically_Allocated_Thread_Servers : 0
 Max_Waiting_Threads (for server task): 6
 Max_Active : 21
 Max_Active_Masters : 17
 Max_Sub_Threads_Per_Master : 6
 Max_Waiting_For_Threads (to finish): 113

Wednesday, September 7, 2011

ParaSail compiler reaches a milestone

The ParaSail compiler has reached a bit of a milestone, in that it now can compile and run what might be considered to be "interesting" programs.  Annotations are not yet enforced, and explicitly concurrent lock-based objects are not yet there, but many other things are working, including implicit and explicit parallelism, dynamic storage management using expandable/shrinkable objects (rather than pointers and garbage collection), fully-shared generic template instantiations, etc.  We are trying to solidify the features that are currently supported so we can make a version of the prototype compiler available for experimentation by others within the next couple of weeks.

Below is one of the "interesting" programs.  This one is an implementation of balanced "AA" trees.  This doesn't illustrate any explicit parallelism, but does illustrate creating and updating interesting data structures without using explicit pointers. Pointer-free data structures allow the compiler to easily understand any aliasing, since there is no hidden sharing between distinct objects. That allows the compiler to eliminate race conditions at compile-time.

Here is the interface to the AA_Tree module. (As a side-note, the program that "HTML"-ized this code was itself written in ParaSail. I've included it at the bottom of this posting.)
interface AA_Tree<Element is Comparable<>> is

    // This module implements a balanced "AA" tree, originally
    // described by Arne Andersson in the "Proceedings of the Workshop
    // on Algorithms and Data Structures," pp 60-71, Springer Verlag, 1993.
    // The following algorithm and descriptions were taken from the
    // WikiPedia article on AA_Tree: 
    //       http://en.wikipedia.org/wiki/AA_tree
    // Note that various additional checks for a null tree have been added.

    // Only two operations are needed for maintaining balance in an AA tree.
    // These operations are called skew and split. Skew is a right rotation
    // when an insertion or deletion creates a left horizontal link. Split
    // is a conditional left rotation when an insertion or deletion creates two
    // horizontal right links, which once again corresponds to two
    // consecutive red links in red-black trees.

    op "[]"() -> optional AA_Tree;
        // Create an empty tree

    func Insert(var T : optional AA_Tree; X : Element);
        // input: X, the value to be inserted, and 
        // T, the root of the tree to insert it into.
        // output: A balanced T' including X.

    func Delete(var T : optional AA_Tree; X : Element);
        // input: X, the value to delete, and T, 
        // the root of the tree from which it should be deleted.
        // output: T', balanced, without the value X.

    op "in"(X : Element; T : optional AA_Tree) -> Boolean;

    func Overlapping(T : optional AA_Tree; X : Element) -> optional Element;
        // input: X, the value to find, and T, 
        // the root of the tree to be searched.
        // output: the element equal to or "unordered" relative to X.

    op "|="(var T : optional AA_Tree; X : Element);

    func First(T : optional AA_Tree) -> optional Element;
      // Return first (smallest) element in tree

    func Last(T : optional AA_Tree) -> optional Element;
      // Return last (greatest) element in tree

    func Remove_First(var T : optional AA_Tree) -> optional Element;
      // Remove first (smallest) element in tree

    func Remove_Last(var T : optional AA_Tree) -> optional Element;
      // Remove last (greatest) element in tree

    func Remove_Any(var T : optional AA_Tree) -> optional Element;
      // Remove some element from tree

    func Count(T : optional AA_Tree) -> Univ_Integer;
      // Return a count of the nodes in the tree

end interface AA_Tree;
Here is the class that provides the implementation for the AA_Tree module:
class AA_Tree is
    var Left : optional AA_Tree;
    var Right : optional AA_Tree;
    var Value : Element;
    var Level : Univ_Integer := 0;

    func Node(Value : Element; Level : Univ_Integer; Left : optional AA_Tree;
      Right : optional AA_Tree) -> AA_Tree is
        // Create a new tree.
        return (Left => Left, Right => Right, Value => Value,
          Level => Level);
    end func Node;

    func Is_Leaf(T : optional AA_Tree) -> Boolean is
        return T not null and then
          T.Left is null and then T.Right is null;
    end func Is_Leaf;

    func Leftmost(ref T : optional AA_Tree) -> ref optional AA_Tree is
        for L => T loop
            if L not null and then L.Left not null then
                // Continue with Left until we reach null
                continue loop with L.Left;
            else
                // Found left-most
                return L;
            end if;
        end loop;
    end func Leftmost;

    func Successor(T : optional AA_Tree) -> optional Element is
        // Return element in tree greater than but closest to T.Value
        if T.Right not null then
            return Leftmost(T.Right).Value;
        else
            return null;
        end if;
    end func Successor;

    func Rightmost(ref T : optional AA_Tree) -> ref optional AA_Tree is
        for R => T loop
            if R not null and then R.Right not null then
                // Keep following down Right side
                continue loop with R.Right;
            else
                // Found right-most
                return R;
            end if;
        end loop;
    end func Rightmost;

    func Predecessor(T : optional AA_Tree) -> optional Element is
        // Return element in tree less than but closest to T.Value
        if T.Left not null then
            return Rightmost(T.Left).Value;
        else
            return null;
        end if;
    end func Predecessor;

    func Skew(var T : optional AA_Tree) is
      // input: T, a node representing an AA tree that needs to be rebalanced.
      // output: T' Another node representing the rebalanced AA tree.

        if T not null and then
          T.Left not null and then
          T.Left.Level == T.Level then
            // The current T.Left becomes new root

            // Exchange value of T.Left with root
            T.Value <=> T.Left.Value;
           
            // Move old root and T.Left.Right over to right side of tree
            T.Left.Right <=> T.Right;
            T.Left.Left <=> T.Right;
            T.Left <=> T.Right;
        end if;
    end func Skew;

    func Split(var T : optional AA_Tree) is
        // input: T, a node representing an AA tree that needs to be rebalanced.
        // output: T' Another node representing the rebalanced AA tree.

        if T not null and then
          T.Right not null and then
          T.Right.Right not null and then
          T.Level == T.Right.Right.Level then
            // T.Right becomes the new root
            // Exchange value and level between root and T.Right
            T.Value <=> T.Right.Value;
            T.Level <=> T.Right.Level;

            // Move old root and T.Right.Left to left side of tree
            T.Left <=> T.Right.Right;
            T.Right.Left <=> T.Right.Right;
            T.Left <=> T.Right;

            // Increment level
            T.Level += 1;
        end if;
    end func Split;

    func Decrease_Level(var T : optional AA_Tree) is
        // input: T, a tree for which we want to remove links that skip levels.
        // output: T with its level decreased.

        if T is null then
            return;
        end if;
           
        var Should_Be : Univ_Integer := 1;

        if T.Left not null then
            Should_Be := T.Left.Level + 1;
        end if;

        if T.Right not null then
            Should_Be := Min(Should_Be, T.Right.Level + 1);
        end if;
            
        if Should_Be < T.Level then
            T.Level := Should_Be;
            if T.Right not null and then
              Should_Be < T.Right.Level then
                T.Right.Level := Should_Be;
            end if;
        end if;
    end func Decrease_Level;

  exports

    op "[]"() -> optional AA_Tree is
        // Create an empty tree
        return null;
    end op "[]";

    // Insertion begins with the normal binary tree search and insertion
    // procedure. Then, as the call stack unwinds (assuming a recursive
    // implementation of the search), it's easy to check the validity of the
    // tree and perform any rotations as necessary. If a horizontal left link
    // arises, a skew will be performed, and if two horizontal right links
    // arise, a split will be performed, possibly incrementing the level of the
    // new root node of the current subtree. Note, in the code as given above,
    // the increment of T.Level. This makes it necessary to continue checking
    // the validity of the tree as the modifications bubble up from the leaves.
    
    func Insert(var T : optional AA_Tree; X : Element) is
        // input: X, the value to be inserted, and 
        // T, the root of the tree to insert it into.
        // output: A balanced T' including X.

        // Do the normal binary tree insertion procedure. 
        // Set the result of the recursive call to the correct 
        // child in case a new node was created or the
        // root of the subtree changes.

        if T is null then
            // Create a new leaf node with X.
            T := Node(X, 1, null, null);
            return;
        end if;

        case X =? T.Value of
          [#less] =>
            Insert(T.Left, X);
          [#greater] =>
            Insert(T.Right, X);
          [#equal | #unordered] =>
            // Note that the case of X == T.Value is unspecified. 
            // As given, an insert will have no effect. 
            // The implementor may desire different behavior.
            return;
        end case;

        // Perform skew and then split. 
        // The conditionals that determine whether or
        // not a rotation will occur or not are inside 
        // of the procedures, as given above.

        Skew(T);
        Split(T);
    end func Insert;

    // As in most balanced binary trees, the deletion of an internal node can
    // be turned into the deletion of a leaf node by swapping the internal node
    // with either its closest predecessor or successor, depending on which are
    // in the tree or on the implementor's whims. Retrieving a predecessor is
    // simply a matter of following one left link and then all of the remaining
    // right links. Similarly, the successor can be found by going right once
    // and left until a null pointer is found. Because of the AA property of
    // all nodes of level greater than one having two children, the successor
    // or predecessor node will be in level 1, making their removal trivial.
    // 
    // To re-balance a tree, there are a few approaches. The one described by
    // Andersson in his original paper is the simplest, and it is described
    // here, although actual implementations may opt for a more optimized
    // approach. After a removal, the first step to maintaining tree validity
    // is to lower the level of any nodes whose children are two levels below
    // them, or who are missing children. Then, the entire level must be skewed
    // and split. This approach was favored, because when laid down
    // conceptually, it has three easily understood separate steps:
    // 
    //     Decrease the level, if appropriate.
    //     Skew the level.
    //     Split the level.
    // 
    // However, we have to skew and split the entire level this time instead of
    // just a node, complicating our code.

    func Delete(var T : optional AA_Tree; X : Element) is
        // input: X, the value to delete, and T, 
        // the root of the tree from which it should be deleted.
        // output: T', balanced, without the value X.

        if T is null then
            // Not in tree -- should we complain?
            return;
        end if;

        case X =? T.Value of
          [#less] =>
            Delete(T.Left, X);
          [#greater] =>
            Delete(T.Right, X);
          [#equal] =>
            // If we're a leaf, easy, otherwise reduce to leaf case. 
            if Is_Leaf(T) then
                T := null;
            elsif T.Left is null then
                // Get successor value and delete it from right tree,
                // and set root to have that value
                const Succ := Successor(T);
                Delete(T.Right, Succ);
                T.Value := Succ;
            else
                // Get predecessor value and delete it from left tree,
                // and set root to have that value
                const Pred := Predecessor(T);
                Delete(T.Left, Pred);
                T.Value := Pred;
            end if;
          [#unordered] =>
            // Not in tree; should we complain?
            return;  
        end case;

        // Rebalance the tree. Decrease the level of all nodes in this level if
        // necessary, and then skew and split all nodes in the new level.

        if T is null then
            return;
        end if;

        Decrease_Level(T);
        Skew(T);
        Skew(T.Right);
        if T.Right not null then
            Skew(T.Right.Right);
        end if;
        Split(T);
        Split(T.Right);
    end func Delete;

    op "in"(X : Element; T : optional AA_Tree) -> Result : Boolean is
        for P => T while P not null loop
            case X =? P.Value of
              [#less] =>
                continue loop with P.Left;
              [#greater] =>
                continue loop with P.Right;
              [#equal] =>
                return #true;
              [#unordered] =>
                return #false;
            end case;
        end loop;
        return #false;  // Not found
    end op "in";

    func First(T : optional AA_Tree) -> optional Element is
      // Return first (smallest) element in tree
        if T is null then
            return null;
        else 
            return Leftmost(T).Value;
        end if;
    end func First;

    func Last(T : optional AA_Tree) -> optional Element is
      // Return last (greatest) element in tree
        if T is null then
            return null;
        else
            return Rightmost(T).Value;
        end if;
    end func Last;


    func Remove_First(var T : optional AA_Tree) -> Result : optional Element is
      // Remove first (smallest) element in tree
        Result := First(T);
        if Result not null then
            Delete(T, Result);
        end if;
    end func Remove_First;

    func Remove_Last(var T : optional AA_Tree) -> Result : optional Element is
      // Remove last (greatest) element in tree
        Result := Last(T);
        if Result not null then
            Delete(T, Result);
        end if;
    end func Remove_Last;

    func Remove_Any(var T : optional AA_Tree) -> Result : optional Element is
      // Remove some element from tree
        if T is null then
            return null;
        end if;
        Result := T.Value;
        if Result not null then
            Delete(T, Result);
        end if;
    end func Remove_Any;

    func Count(T : optional AA_Tree) -> Univ_Integer is
      // Return a count of the nodes in the tree
        if T is null then
            return 0;
        else
            return Count(T.Left) + Count(T.Right) + 1;
        end if;
    end func Count;

    op "|="(var T : optional AA_Tree; X : Element) is
        Insert(T, X);
    end op "|=";

    func Overlapping(T : optional AA_Tree; X : Element) -> optional Element is
        // input: X, the value to find, and T, 
        // the root of the tree to be searched.
        // output: the element equal to or "unordered" relative to X.
        if T is null or else T.Value is null then
            return null;
        else
            case X =? T.Value of
              [#less] =>
                return Overlapping(T.Left, X);
              [#greater] =>
                return Overlapping(T.Right, X);
              [#equal | #unordered] =>
                // Close enough
                return T.Value;
            end case;
        end if;
    end func Overlapping;

end class AA_Tree;
Here is a small test program for AA_Tree:
func Test_AA_Tree(A : Univ_Integer; B : Univ_Integer; C : Univ_Integer) is
    type Univ_Tree is AA_Tree<Univ_Integer>;
    var T : Univ_Tree := [];
    var X : Univ_Integer := A;

    Insert(T, A);
    Println("Count = " | Count(T) | " after insert of " | A);
    Insert(T, B);
    Println("Count = " | Count(T) | " after insert of " | B);
    Insert(T, C);
    Println("Count = " | Count(T) | " after insert of " | C);

    Insert(T, A);
    Println("Count = " | Count(T) | " after another insert of " | A);

    Println(A | " in T = " | [[A in T]]);
    Println(B | " in T = " | [[B in T]]);
    Println(C | " in T = " | [[C in T]]);
    Println("7 in T = " | [[7 in T]]);

    for E := Remove_First(T) then Remove_First(T) while E not null loop
        Println("Remove_First = " | E);
    end loop;

    Println("Count after loop : " | Count(T));

    for I in 1..10 forward loop
        Insert(T, I);
        Println("Count = " | Count(T) | " after insert of " | I);
    end loop;

    for L := Remove_Last(T) then Remove_Last(T) while L not null loop
        Println("Remove_Last = " | L);
    end loop;

    Println("Count after loop : " | Count(T));

    for J in 1..10 reverse loop
        Insert(T, J);
        Println("Count = " | Count(T) | " after insert of " | J);
    end loop;

    Println("Count after loop : " | Count(T));

    Println("Overlapping(T, 5) = " | Overlapping(T, 5));

    for Z := Remove_Any(T) then Remove_Any(T) while Z not null loop
        Println("Remove_Any = " | Z);
    end loop;

    Println("Count after loop : " | Count(T));

    for K in 1..10 loop
        Insert(T, K);
        Println("Count = " | Count(T) | " after insert of " | K);
    end loop;

    for F := Remove_First(T) then Remove_First(T) while F not null loop
        Println("Remove_First = " | F);
    end loop;

    Println("Count after loop : " | Count(T));

end func Test_AA_Tree;
Here is the ParaSail program that was used to "HTML"-ize the listings above (as well as the one below!). Not terribly sophisticated, but illustrates some of the character handling:
func Html_Escape(C : Univ_Character) -> Univ_String is
    // Do single-character escapes
    case C of
      ['<'] =>
        return "&lt;";
      ['>'] =>
        return "&gt;";
      ['&'] =>
        return "&amp;";
      ['\\'] =>
        return "\\";    // Prevent "Print" from expanding control chars
      [..] =>
        return "" | C;  // Convert character into a string
    end case;
end func Html_Escape;

func Htmlize_Line(Orig : Univ_String) -> Result : Univ_String is
    // bold lower case words that are not in comments or
    // character, string, or enum literals

    Result := "";
    var I := 1;
    const L := Length(Orig);
    var State : Univ_Enumeration := #other;
    while I <= L loop
        var C := Orig[I];
        case C of
          ['\\'] =>
            if State == #string_literal or else State == #char_literal then
                // skip next character no matter what it is
                if I < L then
                    Result |= Html_Escape(C);
                    I += 1;
                    C := Orig[I];
                end if;
            end if;
          ['/'] =>
            if I < L and then Orig[I+1] == '/' then
                // comment, italicize it
                Result |= "<i>" | Html_Escape(C);
                while I < L loop
                    I += 1;
                    Result |= Html_Escape(Orig[I]);
                end loop;
                Result |= "</i>";
                C := null;
            end if;
          ['a' .. 'z'] =>
            if State == #other then
                // Presume this is a reserved word, so bold it
                Result |= "<b>" | C;
                while I < L and then Orig[I+1] in 'a' .. 'z' loop
                    I += 1;
                    Result |= Orig[I];
                end loop;
                Result |= "</b>";
                C := null;
            end if;
            
          ['#' | '0'..'9' | 'A' .. 'Z' | '_'] =>
            // Presume this is not a reserved word, pass through as is
            if State == #other then
                State := #unreserved;
            end if;

          ['"'] =>
            if State == #string_literal then
                // End of string literal
                State := #other;
            elsif State != #char_literal then
                State := #string_literal;
            end if;

          ['\''] =>
            if State == #char_literal then
                // End of char literal
                State := #other;
            elsif State != #string_literal then
                State := #char_literal;
            end if;

          [..] =>
            if State != #string_literal and then State != #char_literal then
                State := #other;
            end if;
        end case;

        if C not null then
            Result |= Html_Escape(C);
        end if;
        I += 1;
    end loop;

    Println(Result);
end func Htmlize_Line;

func Htmlize() is
    // Htmlize the standard input, 
    //  putting the result on the standard output
    Println("<pre>");
    loop
        const Line : Univ_String := Readln();
        if Line is null then
            // End of file indicated by "null"
            exit loop;
        end if;
        Htmlize_Line(Line);
    end loop;
    Println("</pre>");
end func Htmlize;

Friday, September 2, 2011

ParaSail on Intel Parallel Programming Talk video

The talk about ParaSail at OSCON 2011 generated a nice bit of media attention, and as a result we were invited to be on the Intel Software Network "Parallel Programming Talk" video show.  The show is now online at:

http://software.intel.com/en-us/blogs/2011/08/26/parasail-a-new-programming-language-parallel-programming-talk-120/

There is a relatively long intro discussion of about 8 minutes, and then we get into the nitty gritty of ParaSail.