'Path' implementation

Pavel Holejsovsky pavel.holejsovsky at upek.com
Wed Sep 8 09:43:53 PDT 2004


Hi,

This is my attempt at finishing implementation of 'src/lib/path.slate'. 
    The patch contains also some basic unit tests, so I believe it is 
not completely broken...  Any comments and corrections are greatly 
appreciated - I'm still trying to find my 'path' through this twisty 
little maze of objects, all alike ;-)

Summary of problems that I met during the implementation follows.  Any 
comments from anyone will be very welcome ... thanks

***********************************************************************
First difficulty I met was 'Types Type rules' object.  This beast 
doesn't have any 'traits' slot (yuck), and therefore (as the comment in 
src/mobius/types.slate says), all methods must be dispatched by sendTo: 
instead of direct calls.  This means that it is not even possible to 
insert it into IdentitySet etc.  I did not want to 'pollute' the 
implementation of the Path by using sendTo: instead of normal method 
calls, so I closed the appropriate code in "[] breakOn: MethodNotFound" 
envelope and it seems to work - 'Types Type rules' is simply ignored 
when searching for path.  Is there any more elegant solution for this?

***********************************************************************
I tried to use ({#a -> #b} as: Dictionary) idiom, but it did not work - 
silently creating bogus dictionaries.  I believe I can fix this (by 
implementing special case of Dictionary WriteStream, I think), but I'm 
not sure if this should work at all (conceptually).

***********************************************************************
hash/= methods - I thought that 'hash' *must* return the same value for 
any two objects for which '=' returns True.  But:

 > addSlot: #a1 valued: {0}.
{0}
 > addSlot: #a2 valued: {0}.
{0}
 > a1 = a2.
True
 > a1 hash.
102089623
 > a2 hash.
127015919

Is this complete misconception on my side, or some problem in current 
slate implementation?

***********************************************************************
There is something fishy with ExtensibleArray.  Following one-liner IMHO 
should work, but:

 > ExtensibleArray newEmpty writer ; #a.
The following condition was signaled:
0 is not a key in {}

I tried to track this down a bit; the condition is signalled from 
iterator.slate, pastEndPut: method;

1: ws@(Sequence WriteStream traits) pastEndPut: obj
2: [| c cs |
3:   c: ws collection.
4:   ws collection: c ; (c newSize: ((c size max: 20) min: 1000000)).
5:   ws writeLimit: ws collection size.
6:   ws collection at: ws position put: obj.
7:   ws position: ws position + 1.
8:   obj
9: ].

The problem seems to come from the fact that collection concatenation on 
line 4 creates ExtensibleArray with 'capacity' based on the 'size' of 
concatenated arrays, and later line 6 tries to write into non-existent 
element of the array.  It can be demostrated like this:

Slate 19> addSlot: #a3 valued: (ExtensibleArray newSize: 5).
(a1 . Types . a2 . prototypes .
	VM . globals . Mixins . a3 .
	traits )
 > a3 size.
0
 > a3 capacity.
5
 > (a3 ; a3) size.
0
 > (a3 ; a3) capacity.
0

I'm not sure what should be done with these, because looking closer at 
ExtensibleArray, I found that I have hard time understanding 
capacity/size idioms; newSize: does not set size but capacity instead, 
size can be changed only by addFirst:/addLast:/removeFirst:/removeLast:, 
  at: and at:put: don't care about size at all...  Is this all intentional?

thanks (mainly for slate, the more I use it the more I like it!), and I 
apologize for such a long posting.

Pavouk

-------------- next part --------------
Index: src/lib/path.slate
===================================================================
RCS file: /var/lib/cvs/slate/slate/src/lib/path.slate,v
retrieving revision 1.1
diff -u -r1.1 path.slate
--- src/lib/path.slate	23 Aug 2004 01:54:51 -0000	1.1
+++ src/lib/path.slate	8 Sep 2004 16:03:31 -0000
@@ -1,9 +1,9 @@
-requires: {#Sequence}.
-provides: {#Path}.
+requires: {#Sequence. #IdentitySet. #Association}.
+provides: {#Path. #RootedPath}.
 
 prototypes addPrototype: #Path derivedFrom: {Cloneable}.
 "A Path represents a sequence of slot-name traversals which can be used to
-reach a destination."
+reach a destination.  Nil represents impossible path."
 Path addSlot: #names valued: {}.
 
 s@(Sequence traits) as: path@(Path traits)
@@ -13,24 +13,61 @@
   newP
 ].
 
-path@(Path traits) from: root to: obj
+p1@(Path traits) = p2@(Path traits)
+[p1 names = p2 names].
+
+path@(Path traits) hash
+[names hash].
+
+path@(Path traits) from: root into: names isFound: isFound 
+		   canTraverseInto: canTraverseInto
+"Core of the path-searching functionality, contains the algorithm for
+breadth-first search of path between objects through slots.  'root' is the
+object where the search begins, 'names' is WriteStream into which are symbols
+specifying found path added.  'isFound' os predicate block, taking 2 arguments
+:name and :value of object to be tested - should return True when specified
+object terminates the search.  'canTraverseInto' is a predicate block which
+allows filtering out slots into which the search should not go.  Method answers
+the target object where the found path leads to, or Nil if requested path does
+not exist."
+[| pathLookupQueue seen |
+  (isFound applyTo: {Nil. root}) ifTrue: [^ root].
+  seen: (IdentitySet newWith: root).
+  pathLookupQueue: 
+    (ExtensibleArray newWith: ExtensibleArray newEmpty -> root).
+  [pathLookupQueue isEmpty] whileFalse:
+    [| pathLookup lookupObject |
+      pathLookup: pathLookupQueue removeFirst.
+      lookupObject: pathLookup value.
+      lookupObject slotNames do:
+        [| :slotName slotValue |
+          slotValue: (lookupObject atSlotNamed: slotName).
+	  [(seen accepts: slotValue) /\ [(seen includes: slotValue) not] 
+	    ifTrue:
+	      [| newPath |
+	        seen include: slotValue.
+	        newPath: pathLookup key copy.
+	        newPath addLast: slotName.
+		(isFound applyTo: {slotName. slotValue}) ifTrue: 
+		  [names ; newPath. ^ slotValue].
+		(canTraverseInto applyTo: {lookupObject. slotName}) ifTrue:
+	          [pathLookupQueue addLast: newPath -> slotValue].
+	      ]
+	  ] breakOn: MethodNotFound
+        ]
+    ].
+  Nil
+].
+
+path@(Path traits) from: root to: target
 "Answer a Path between the given objects, using a raw breadth-first search
-through all slot paths, avoiding duplicate visits."
-[| pathNames this seen trail index |
-  "start with empty path-stack of slot names"
-  pathNames: Stack newEmpty.
-  "start from root; call it `this`"
-  this: root.
-  "Track objects traversed with `seen`"
-  seen: ({root} as: IdentitySet).
-  "iterate through this' slots - if any are the object, accumulate and return the path"
-  currentNames: this slotNames.
-  currentNames do:
-    [| :each | (this atSlotNamed: each) == obj
-	       ifTrue: [pathNames push: each. ^ (pathNames as: path)]].
-  "if not, make `this` the first "
-  index: 0.
-  "TODO!"
+through all slot paths, avoiding duplicate visits.  Answers Nil when no path
+can be found."
+[| names |
+  names: path names newEmpty writer.
+  (path from: root into: names isFound: [| :name :value | value == target]
+        canTraverseInto: [| :obj :name | True]) 
+    ifNotNil: [^ (names contents as: Path)]
 ].
 
 path@(Path traits) to: obj
@@ -49,9 +86,9 @@
 
 path@(Path traits) targetFrom: root
 [
-  path names inject: root into:
-    [| :eachName :obj | (obj atSlotNamed: eachName)
-       on: SlotNotFound do: [^ Nil]]
+  [path names inject: root into:
+    [| :obj :eachName | obj atSlotNamed: eachName]]
+   on: SlotNotFound do: [| :c | ^ Nil]
 ].
 
 path@(Path traits) printOn: s
@@ -69,19 +106,29 @@
 "Answer a path with the root object forgotten."
 [rooted names as: path].
 
+p1@(RootedPath traits) = p2@(RootedPath traits)
+[(p1 root = p2 root) /\ [p1 names = p2 names]].
+
 path@(RootedPath traits) unrooted
 [path as: Path].
 
-path@(RootedPath traits) from: root to: obj
-[
-  resend root: root
+path@(RootedPath traits) from: root to: target
+[| newP |
+  (newP: resend) ifNotNil: [newP: (path from: root as: newP names)].
+  newP
+].
+
+path@(RootedPath traits) from: root as: s
+[| newP |
+  newP: path clone.
+  newP names: s.
+  newP root: root.
+  newP
 ].
 
 path@(RootedPath traits) target
 [
-  path names inject: path root into:
-    [| :eachName :obj | (obj atSlotNamed: eachName)
-       on: SlotNotFound do: [^ Nil]]
+  path expanded targetFrom: path root
 ].
 
 path@(RootedPath traits) reduced
@@ -91,9 +138,12 @@
   names: path names newEmpty writer.
   this: path root.
   path names do: [| :each | (this hasSlotNamed: each)
-		    ifTrue: [(this hasDelegateNamed: each) not
-				 ifFalse: [names nextPut: each]]
-		    ifFalse: [this slotNotFoundNamed: each].
+		    ifTrue: [(this hasDelegateNamed: each)
+				 ifFalse: [names nextPut: each].
+			       this: (this atSlotNamed: each)]
+		    ifFalse: [this slotNotFoundNamed: each]].
+  (names contents isEmpty) /\ [path names isEmpty not]
+    ifTrue: [names nextPut: path names last].
   names contents as: path
 ].
 
@@ -105,7 +155,13 @@
 [| names this |
   names: path names newEmpty writer.
   this: path root.
-  "TODO: search delegates for next data slot in the path."
+  path names do: 
+    [| :each | 
+      (path from: this into: names
+            isFound: [| :name :value | name == each]
+            canTraverseInto: [| :obj :name | obj hasDelegateNamed: name])
+        ifNil: [this slotNotFoundNamed: each]
+    ].
   names contents as: path
 ].
 
Index: tests/init.slate
===================================================================
RCS file: /var/lib/cvs/slate/slate/tests/init.slate,v
retrieving revision 1.2
diff -u -r1.2 init.slate
--- tests/init.slate	3 Aug 2004 01:57:19 -0000	1.2
+++ tests/init.slate	8 Sep 2004 16:07:18 -0000
@@ -1,10 +1,12 @@
 load: 'src/lib/test.slate'.
 load: 'src/lib/tokenizer.slate'.
 load: 'src/lib/matrix.slate'.
+load: 'src/lib/path.slate'.
 
 load: 'tests/regression/wordcount.slate'.
 load: 'tests/dictionary.slate'.
 load: 'tests/numeric.slate'.
 load: 'tests/matrix.slate'.
 load: 'tests/range.slate'.
+load: 'tests/path.slate'.
 load: 'tests/test.slate'.

--- /dev/null	2004-09-08 18:09:30.813000000 +0200
+++ tests/path.slate	2004-09-08 18:00:17.540817100 +0200
@@ -0,0 +1,180 @@
+UnitTests addPrototype: #Path derivedFrom: {TestCase}.
+"Unit test for Path functionality."
+
+_@(UnitTests Path traits) testLobby
+"Create object tree for testing of Path finding.  Answered tree resembles
+slate's lobby-rooted tree organization.  We must take care to avoid the
+possibility to find path from real lobby to this test-one, otherwise test
+results would be very screwed up.  That's why this testLobby graph is created
+on-demand and answered instead of pre-creating it in named slot of UnitTests
+Path."
+[| newLobby |
+  newLobby: Namespace clone.
+  newLobby ensureDelegatedNamespace: #prototypes.
+  newLobby prototypes addPrototype: #p1 derivedFrom: {Cloneable}.
+  newLobby prototypes addPrototype: #p2 derivedFrom: {newLobby p1}.
+  newLobby prototypes ensureDelegatedNamespace: #collections.
+  newLobby collections addPrototype: #c1 derivedFrom: {Cloneable}.
+  newLobby collections addPrototype: #c2 derivedFrom: {newLobby c1}.
+  newLobby ensureNamespace: #VM.
+  newLobby VM ensureNamespace: #ByteCode.
+  newLobby VM ByteCode addImmutableSlot: #sendMessage valued: 0.
+  newLobby ensureNamespace: #Types.
+  newLobby Types addPrototype: #rules derivedFrom: {Cloneable}.
+  newLobby Types rules removeSlot: #traits.
+  newLobby
+].
+
+t@(UnitTests Path traits) testAsMethod
+[
+  { {}. {#a}. {#a. #b} } do:
+    [| :s p |
+      p: (s as: Path).
+      t assert: (s as: p names) = p names
+	description: s print ; ' as: Path produced ' ; p print
+    ].
+].
+
+t@(UnitTests Path traits) testComparisonMethod
+[
+  { 
+    { {}. {}. True }.
+    { {}. {#a}. False }.
+    { {#a}. {#b}. False }.
+    { {#a. #b}. {#a. #b}. True }.
+    { {#a. #b}. {#a. #b. #c}. False}.
+  } do:
+    [| :case p1 p2 | 
+      p1: (case first as: Path).
+      p2: (case second as: Path).
+      t assert: (p1 = p2) == case third
+	description: 
+	  p1 print ; ' = ' ; p2 print ; ' generated incorrect result'
+    ]
+].
+
+t@(UnitTests Path traits) testPathFromToMethod
+"Tests functionality of the heart of Path library, Path from:to: method."
+[| testLobby |
+  testLobby: t testLobby.
+  {
+    { testLobby. testLobby. {} }.
+    { testLobby. testLobby prototypes. {#prototypes} }.
+    { testLobby. testLobby c2. {#prototypes. #collections. #c2} }.
+    { testLobby. testLobby VM ByteCode sendMessage.
+      {#VM. #ByteCode. #sendMessage} }.
+    { testLobby c1. testLobby VM. Nil }.
+    { testLobby c2 traits. testLobby c1 traits. {#parent0} }
+  } do: 
+      [| :tripple root target names path |
+        root: tripple first.
+        target: tripple second.
+        names: tripple third.
+	path: (Path from: root to: target).
+	names isNil ifTrue: [t assert: path isNil]
+		    ifFalse: 
+		      [t assert: (path isSameAs: Path) /\
+			         [path names = (names as: path names)]
+			 description:
+			   'Got path "' ; path print ; '" while expected "' 
+			     ; names print ; '".'
+		      ]
+      ]
+].
+
+t@(UnitTests Path traits) testTargetFromMethod
+[| testLobby |
+  testLobby: t testLobby.
+  {
+    { testLobby. {}.  testLobby }.
+    { testLobby. {#prototypes}. testLobby prototypes }.
+    { testLobby. {#prototypes. #collections. #c2}. testLobby c2 }.
+    { testLobby. {#a. #b}. Nil }.
+    { testLobby c2. {#traits. #parent0}. testLobby c2 parent0 }
+  } do:
+      [| :case target |
+	target: ((case second as: Path) targetFrom: case first).
+        t assert: target == case third
+	  description: 'Path "' ; case second print ; '" from "' ; 
+	  case first print ; '" does not lead where expected ("' ;
+	  target print ; '" instead)'
+      ]
+].
+
+t@(UnitTests Path traits) testRootedPathBase
+[| testLobby p |
+  testLobby: t testLobby.
+
+  p: (RootedPath from: testLobby to: testLobby c2).
+  t assert: ((p as: Path) isSameAs: Path)
+    description: 'RootedPath as: Path is broken.'.
+  t assert: (p unrooted isSameAs: Path)
+    description: 'RootedPath unrooted is broken.'.
+  t assert: (RootedPath from: testLobby to: #a) isNil
+    description: 'RootedPath from:to: is broken.'.
+  t assert: (RootedPath from: testLobby as: {#collections}) = 
+            (RootedPath from: testLobby as: {#collections})
+    description: 'RootedPath comparison is broken.'.
+  t assert: (RootedPath from: testLobby as: {#collections}) ~=
+            (RootedPath from: lobby as: {#collections})
+    description: 'RootedPath comparison is broken (root not considered).'.
+  t assert: (RootedPath from: testLobby as: {#collections}) ~=
+            (RootedPath from: testLobby as: {#prototypes})
+    description: 'RootedPath comparison is broken (path not considered).'
+].
+
+t@(UnitTests Path traits) testRootedPathReduction
+[| testLobby p |
+  testLobby: t testLobby.
+  {
+    { testLobby. testLobby c2. {#c2} }.
+    { testLobby. testLobby VM ByteCode sendMessage. 
+      {#VM. #ByteCode. #sendMessage} }.
+    { testLobby. testLobby prototypes. {#prototypes} }.
+    { testLobby. testLobby. {} }
+  } do:
+    [| :case p |
+      p: (RootedPath from: case first to: case second) reduced.
+      t assert: (p isSameAs: RootedPath)
+	description: 'RootedPath reduced returns wrong type'.
+      t assert: p = (case third as: Path)
+	description: 'RootedPath reduced failed; from "' ; case first print ;
+	             '" to "' ; case second print ; '" got "' ; p print ;
+	             '" but expected "' ; case third print ; '".'
+    ]
+].
+
+t@(UnitTests Path traits) testRootedPathExpansion
+[| testLobby p |
+  testLobby: t testLobby.
+  {
+    { testLobby. {}. {} }.
+    { testLobby. {#prototypes}. {#prototypes} }.
+    { testLobby. {#c2}. {#prototypes. #collections. #c2} }.
+    { testLobby. {#collections}. {#prototypes. #collections} }
+  } do:
+    [| :case p |
+      p: (RootedPath from: case first as: case second) expanded.
+      t assert: (p names = case third) /\ [p root = case first]
+	description: 'RootedPath expanded failed; from "' ; case second print ;
+	             '" expanded to "' ; p names print ; '" but expected "' ;
+	             case third print ; '".'
+    ].
+].
+
+t@(UnitTests Path traits) suite
+[| suite |
+  suite: TestSuite newEmpty.
+  suite tests
+    addAll:
+      {
+        t newForSelector: #testAsMethod.
+	t newForSelector: #testComparisonMethod.
+        t newForSelector: #testPathFromToMethod.
+	t newForSelector: #testTargetFromMethod.
+	t newForSelector: #testRootedPathBase.
+	t newForSelector: #testRootedPathReduction.
+	t newForSelector: #testRootedPathExpansion
+      }.
+  suite
+].


More information about the Slate mailing list