'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