Skip to content
Next
Projects
Groups
Snippets
Help
Loading...
Help
Support
Submit feedback
Contribute to GitLab
Switch to GitLab Next
Sign in / Register
Toggle navigation
G
Guile Log
Project
Project
Details
Activity
Releases
Cycle Analytics
Insights
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Locked Files
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
Wiki
Wiki
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Commits
Issue Boards
Open sidebar
gulelog
Guile Log
Commits
72ac61f1
Commit
72ac61f1
authored
Aug 16, 2015
by
Stefan Israelsson Tampe
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
lookup functions and tree lookup example is now active
parent
b5aec8cb
Changes
1
Hide whitespace changes
Inline
Sidebyside
Showing
1 changed file
with
58 additions
and
17 deletions
+58
17
inheritance.scm
logic/guilelog/inheritance.scm
+58
17
No files found.
logic/guilelog/inheritance.scm
View file @
72ac61f1
...
...
@@ 11,6 +11,7 @@
compilesupsub
compilesetrepresentation
mktree
findmatchingsets
))
;; Syntax helpers
...
...
@@ 299,10 +300,18 @@ a natural generational mapping to help in constructing a match tree.
#
:i>sups
i>sups
))))))))
(
define
compilesetrepresentation
(
caselambda
((
setbits
)
(
compilesetrepresentation
(
fluidref
*currentsettheory*
)
setbits
))
(
caselambda
(()
(
compilesetrepresentation
(
fluidref
*currentsettheory*
)
))
((
setbitsortheory
)
(
if
(
number?
setbitsortheory
)
(
compilesetrepresentation
(
fluidref
*currentsettheory*
)
setbitsortheory
)
(
compilesetrepresentation
setbitsortheory
(

(
getnew
setbitsortheory
)
1
))))
((
theory
setbits
)
(
let
((
deps
(
geti>subs
theory
))
(
sups
(
geti>sups
theory
)))
...
...
@@ 399,11 +408,15 @@ a natural generational mapping to help in constructing a match tree.
Balanced
binary
tree
compilation
You
take
a
set
i,
finds
it
's
subs
sub
and
if
sub

m,
then
dive
each
if
we
have
a
set
s
and
would
like
to
lookup
the
matches

#
(
define
mktree
(
caselambda*
((
#
:key
(
setbits
#f
))
((
#
:key
(
setbits
(

(
getnew
(
fluidref
*currentsettheory*
))
1
)
))
(
mktree
(
fluidref
*currentsettheory*
)
#
:setbits
setbits
))
((
theory
#
:key
(
setbits
(

(
getnew
theory
)
1
)))
(
define
(
clusterize
setbits
)
...
...
@@ 412,7 +425,7 @@ a natural generational mapping to help in constructing a match tree.
(
if
(
pair?
ss
)
(
let*
((
i
(
car
ss
)))
(
if
(
=
(
logand
done
i
)
0
)
(
let
((
ih
(
logand
setbits
(
hashref
i>subs
i
#f
))))
(
let
((
ih
(
logand
setbits
(
geti
i>subs
i
))))
(
cons
ih
(
lp
(
cdr
ss
)
(
logior
done
ih
))))
(
lp
(
cdr
ss
)
done
)))
'
()))))
...
...
@@ 428,7 +441,6 @@ a natural generational mapping to help in constructing a match tree.
(
cons
a
(
mktree1
t
))))
cls
))))
(
define
(
linearize
tree
)
(
let
lp
((
r
tree
))
(
match
r
...
...
@@ 436,7 +448,11 @@ a natural generational mapping to help in constructing a match tree.
(()
'
())
(
x
(
list
x
)))))
(
define
setlist
(
pk
(
linearize
(
mktree1
setbits
))))
(
define
(
p
x
)
(
pk
(
map
(
lambda
(
x
)
(
reverselookup
theory
x
))
x
))
x
)
(
define
setlist
(
p
(
linearize
(
mktree1
setbits
))))
(
define
tree
(
let
((
i>f
(
geti>f
theory
)))
...
...
@@ 459,12 +475,37 @@ a natural generational mapping to help in constructing a match tree.
Algorithm
to
lookup
the
matching
sets
iiis,
preliminary
this
will
be
called
from
cland
in
the
indexer
.

#
#
;
(
define
(
findmatchingsets
i
tree
)
(
let
((
ih
(
hashref
itosubs
i
0
)))
(
folddynlistlr
(
lambda
(
x
seed
)
(
logior
(
vectorref
x
1
)
seed
))
tree
0
(
lambda
(
x
)
(
not
(
=
(
logand
x
ih
)
0
))))))
(
define
reverselookup
(
caselambda
((
set
)
(
lookup
(
fluidref
*currentsettheory*
)
set
))
((
theory
set
)
(
define
(
tr
x
)
(
let
lp
((
x
x
)
(
th
theory
))
(
aif
(
it
)
(
getparent
th
)
(
lp
(
geti
(
getj>i
th
)
x
)
it
)
(
geti
(
geti>set
th
)
x
))))
(
tr
set
))))
(
define
lookup
(
caselambda
((
set
)
(
lookup
(
fluidref
*currentsettheory*
)
set
))
((
theory
set
)
(
aif
(
it
)
(
getparent
theory
)
(
geti
(
geti>j
theory
)
(
lookup
it
set
))
(
geti
(
getset>i
theory
)
set
)))))
(
define
(
findmatchingsets
theory
set
tree
)
(
let
((
ih
(
geti
(
geti>subs
theory
)
(
lookup
theory
set
))))
(
let
lp
((
l
(
bitstois
(
folddynlistlr
(
lambda
(
x
seed
)
(
logior
(
vectorref
x
0
)
seed
))
tree
0
(
lambda
(
x
)
(
not
(
=
(
logand
x
ih
)
0
)))))))
(
if
(
pair?
l
)
(
cons
(
reverselookup
theory
(
car
l
))
(
lp
(
cdr
l
)))
'
()))))
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment