<movie>
    <title>Star Trek: Insurrection</title>
    <star>Patrick Stewart</star>
    <star>Brent Spiner</star>
    <theater>
        <theater-name>MonoPlex 2000</theater-name>
        <showtime>14:15</showtime>
        <showtime>16:30</showtime>
        <showtime>18:45</showtime>
        <showtime>21:00</showtime>
        <price>
            <adult>$8.50</adult>
            <child>$5.00</child>
        </price>
    </theater>
    <theater>
        <theater-name>Bigscreen 1</theater-name>
        <showtime>19:30</showtime>
        <price>$6.00</price>
    </theater>
</movie>

For selecting the theaters
---------------------------------------------
XPath==> /movie/theater

[theater [theater-name ["MonoPlex 2000"] showtime ["14:15"] showtime ["16:30"] showtime ["18:45"] showtime ["21:00"] price [adult ["$8.50"] child ["$5.00"]]]]
[theater [theater-name ["Bigscreen 1"] showtime ["19:30"] price ["$6.00"]]]

For selecting all the stars
----------------------------------------
XPath==> //star

[star ["Patrick Stewart"]]
[star ["Brent Spiner"]]

For selecting the first showtime of all theaters
------------------------------------------------------------------------
XPath==>//theater/showtime(1)

[showtime ["14:15"]]
[showtime ["19:30"]]

For selecting all the showtimes of the second theater
------------------------------------------------------------------------------------
XPath==>//theater(2)/showtime

[showtime ["19:30"]]

For selecting all the showtimes of the Bigscreen1 theater
-----------------------------------------------------------------------------------------
XPath==>//theater[./theater-name/Bigscreen 1]/showtime

[showtime ["19:30"]]

For selecting the theaters with a showtime at 21:00
--------------------------------------------------------------------------------
XPath==>//theater[./showtime/21:00]

[theater [theater-name ["MonoPlex 2000"] showtime ["14:15"] showtime ["16:30"] showtime ["18:45"] showtime ["21:00"] price [adult ["$8.50"] child ["$5.00"]]]]

tree_geometry_rules: [
	descendant [X Y][
		child [X Y]]
	descendant [X Y][
		child [X Z]
		descendant[Z Y]]]
db2: copy db
assert  db2 tree_geometry_rules
extended_db_facts: copy []
for-which db2 [X Y] [
	descendant [X Y]
][
	append extended_db_facts compose/deep [descendant [[(X)] [(Y)]]]
]
assert db extended_db_facts
...

tree_geometry_rules: [
    descendant [X Y][
        db/child [X Y]
    ]
    db/descendant [X Y][
        db/child [X Z]
        db/descendant[Z Y]
    ]
]
for-which tree_geometry_rules [X Y] [
	descendant [X Y]
][
	assert db compose/deep [descendant [[(X)] [(Y)]]]
]

tree_geometry_rules: assert none [
    descendant [X Y][
        db/child [X Y]
    ]
    descendant [X Y][
        db/child [X Z]
        descendant[Z Y]
    ]
]
for-which tree_geometry_rules [X Y] [
	descendant [X Y]
][
	assert db compose/deep [descendant [[(X)] [(Y)]]]
]

xpath_rules: [
	; for addressing the whole document
	xpath ["/" X][
		xp [["root" "" "" "" ""] X]]	
	xp [["root" "" "" "" ""] doc][
		xml [X]]
	; for not having path starting with / (would be more difficult to handle in the parsepath function)
	xpath [Pl X][
		xp [(parsepath join "root" Pl) X]]
	; child axis		
	xp [[Pathup "/" Test "" ""] X][
		xp [(parsepath Pathup) Y]	
		child [X Y]
		equal? [(to-string X/1) Test]]
	; descendant axis
	xp [[Pathup "//" Test "" ""] X][
		xp [(parsepath Pathup) Y]		
		descendant [X Y]
		equal? [(to-string X/1) Test]]
	; nodetest tied with a position
	xp [[P1 P2 P3 _ Pos] X][
		not-equal? ["" Pos]	
		xp [(parsepath join P1 [P2 P3]) X]		
		index [X Pos]]
	; nodetest tied with a predicate (i.e. a path relative to the context node . (dot))	
	xp [[P1 P2 P3 P4 _] X][
		not-equal? ["" P4]		
		xp [(parsepath join P1 [P2 P3]) X]
		xp [(parsepath join P1 [P2 P3 next P4]) Y]
		descendant[Y X]]
]

trim/lines xmldata
parse xmldata [any [to "> <" mark: (mark: next mark remove mark mark: next mark) :mark]]

space: charset " ^/^M^-"
parse xmldata [any [
	">" s: some space e: (s: remove/part s e) :s
|
	s: some space e: "<" (s: remove/part s e) :s
|
	skip
]]

parse-doc: func [
	data [block!]
	/local parents elements rule element attribute search wrk-facts
][
	parents: copy []
	elements: copy/deep [[]]
	parse data rule: [any [
		element: skip ( ; process the element
			unless search: find elements/1 element/1 [
				search: head insert elements/1 reduce [element/1 0]
			]
			append db_facts compose/deep/only [index [(element) (search/2: search/2 + 1)]]
			append db_facts compose/deep/only [child [(element) (parents/1)]]
			wrk-facts: tail db_facts
			foreach parent parents [
				insert wrk-facts compose/deep/only [descendant [(element) (parent)]]
			]
		)
		any [attribute: word! string! ( ; process the attributes
			insert db_facts compose/deep/only [attribute [(element) (attribute)]]
		)]
		( ; Push the current element
			insert/only parents element ; stack the tag
			insert/only elements copy [] ; stack a new element list
		)
		opt into rule ; process the childs
		( ; Pop the current element
			remove parents ; unstack the element
			remove elements ; unstack the element list
		)
	]]
]

doc: copy [/]
doc: append/only doc xml2rebxml xmldata
parse-doc doc
db: assert none [xml [doc]]
assert db db_facts

	xpath [P Y][
		xpa [P X]
		equal? [false (none? X/2)]
		equal? [Y (reduce [X/1 X/2])]]

prompt: has [expression r s e][
	expression: copy ""
	expression: ask "XPath==> "
	either not empty? expression [
		r: 0
		for-which db [X][
			xpath [expression X]
		][
			parse X [
				s: [ ; soit un tag
					word!
					any [word! string!]
					block!
				| ; soit n'importe quoi d'autre (en principe un string!)
					skip
				] e: (probe copy/part s e)
			]
			r: r + 1
		]
		print [r "solution(s)"]
		false
	][true]
]

parse-doc: func [
	data [block!]
	/local parents elements rule element attribute search wrk-facts
][
	parents: copy []
	elements: copy/deep [[]]
	parse data rule: [any [
; D'abord on repère le début et la fin de l'élément
		s: [ ; soit un tag
			word! ; le tag
			any [word! string!] ; les éventuels attributs
			block! ; les enfants
		| ; soit n'importe quoi d'autre (en principe un string!)
			skip
		] e: (element: copy/part s e)
; On se repositionne au début de l'élément
		:s
; Puis on traite l'élément
		skip ( ; process the element
			unless search: find elements/1 element/1 [
				search: head insert elements/1 reduce [element/1 0]
			]
			append db_facts compose/deep/only [index [(element) (search/2: search/2 + 1)]]
			append db_facts compose/deep/only [child [(element) (parents/1)]]
			wrk-facts: tail db_facts
			foreach parent parents [
				insert wrk-facts compose/deep/only [descendant [(element) (parent)]]
			]
		)
		any [s: word! string! e: ( ; process the attributes
			insert db_facts compose/deep/only [attribute [(element) (copy/part s e)]]
		)]
		( ; Push the current element
			insert/only parents element ; stack the tag
			insert/only elements copy [] ; stack a new element list
		)
		opt into rule ; process the childs
		( ; Pop the current element
			remove parents ; unstack the element
			remove elements ; unstack the element list
		)
	]]
]

xpath_rules: [
	xpath ["/" X][
		xp [["root" "" "" "" ""] X]]	
	xp [["root" "" "" "" ""] doc][
		xml [X]]
	; for not having path starting with / (would be more difficult to handle in the parsepath function) 
	; and for getting the element and its subtree only (without the following siblings if any)
	xpath [P Y][
		xp [(parsepath join "root" P) X]
		equal? [Y (either X/2 = none [X/1] reduce [reduce [X/1 X/2]]) ]]		
	; child axis		
	xp [[Pathup "/" Test "" ""] X][
		xp [(parsepath Pathup) Y]	
		child [X Y]
		equal? [(to-string X/1) Test]]
	; descendant axis
	xp [[Pathup "//" Test "" ""] X][
		xp [(parsepath Pathup) Y]		
		descendant [X Y]
		equal? [(to-string X/1) Test]]
	; nodetest tied with a position
	xp [[P1 P2 P3 _ Pos] X][
		not-equal? ["" Pos]	
		xp [(parsepath join P1 [P2 P3]) X]		
		index [X Pos]]
	; nodetest tied with a predicate (i.e. a path relative to the context node . (dot))	
	xp [[P1 P2 P3 P4 _] X][
		not-equal? ["" P4]		
		xp [(parsepath join P1 [P2 P3]) X]
		xp [(parsepath join P1 [P2 P3 next P4]) Y]
		descendant[Y X]]
]

parse-doc: func [
parse the rebxml block and create db atomic facts
parent [block!]
parent block
data [block!]
child block
/local element pcdata attribute value subtree elementlist search pos][
element: pcdata: attribute: value: subtree: none
elementlist: copy []
parse data rule: [ 
	any [
		element: word!  ; element
			(either search: find elementlist element/1 [
				pos: search/2: search/2 + 1][
				pos: 1
				append elementlist reduce [element/1 1]]
			append db_facts compose/deep/only [index [(element) (pos)]]
			append db_facts compose/deep/only [child [(element) (parent)]])
		any [attribute: word! value: string! ; attribute/value
			(probe attribute/1
			probe value/1
			append db_facts compose/deep/only [child [(attribute) (element)]]
			append db_facts compose/deep/only [child [(value) (attribute)]])] 
		subtree: block!  ; subtree
			(parse-doc element subtree/1)
		| pcdata: string! ;pcdata
			(append db_facts compose/deep/only [child [(pcdata) (parent)]])
		| ; anything else (normally / if empty element)
			skip
		] ]
]