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
7a84510e
Commit
7a84510e
authored
Jul 16, 2015
by
Stefan Israelsson Tampe
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
added scheme file to setup structures to match acyclic graphs
parent
58bc4f42
Changes
1
Hide whitespace changes
Inline
Sidebyside
Showing
1 changed file
with
175 additions
and
0 deletions
+175
0
inheritance.scm
logic/guilelog/inheritance.scm
+175
0
No files found.
logic/guilelog/inheritance.scm
0 → 100644
View file @
7a84510e
(
definemodule
(
logic
guilelog
inheritance
)
#
:usemodule
(
logic
guilelog
dynlist
)
#
:export
())
(
define
i
1
)
(
define
settoi
(
makehashtable
))
(
define
itoset
(
makehashtable
))
(
define
settoinher
(
makehashtable
))
(
define
itoinher
(
makehashtable
))
(
define
(
newset
set
)
(
let
((
j
i
))
(
set!
i
(
*
i
2
))
(
hashset!
settoi
set
j
)
(
hashset!
itoset
j
set
)
(
hashset!
settoinher
set
j
)
j
))
(
define
settoinher
(
makehashtable
))
(
define
(
a>b
seta
setb
)
(
aif
(
bh
)
(
hashref
settoinher
setb
#f
)
(
aif
(
ah
)
(
hashref
settoinher
seta
#f
)
(
aif
(
i
)
(
hashref
settoi
a
#f
)
(
let
((
h
(
logior
ah
bh
)))
(
hashset!
itoinher
u
h
)
(
hashset!
settoinher
seta
h
))))))
(
define
(
gethighbit
x
)
(
ash
1
(

(
integerlength
x
)
1
)))
(
define
(
getallinh
set
)
(
let
((
ih
(
hashref
settoinher
set
#f
)))
(
let
lp
((
ih
ih
))
(
if
(
=
ih
0
)
'
()
(
let
((
high
(
gethighbit
ih
)))
(
cons
(
hashref
itoset
high
#f
)
(
lp
(
lognot
ih
high
))))))))
#

Typically
function
matchers
make
use
of
a
subset
of
the
available
types
and
by
restricting
the
scope
of
the
possible
matching
sets
we
can
allow
for
faster
deduction
e
.
g
.
programs
can
have
1000
sets
and
then
it
is
a
bit
clumsy
to
scan
all
the
sets
at
dispatch
.
All
this
information
is
dynamicalle
created
.
It
would
be
nice
to
be
able
to
create
static
construction
.
We
could
start
naming
all
static
functins
and
use
them
in
the
formation
to
avoid
dispatch
caching
of
common
formations
ans
sub
matchers
is
also
a
very
god
task
to
take
on
also
being
able
to
indicate
in/out
relations
could
enable
severe
speedups
.
what
about
...
map
(
F
:
+
X
:
(
list
integer
)
,...,
Z
integer
)
F
(
Z,X:A,
...
)
.
+
(
X:r
(
A
)
,...,
r
(
A
)
...
Z:integer
)
map
+
(
X:number,
...,
X:number
)
Also
we
need
to
indicate
that
a
term
is
an
autocut
e
.
g
.
no
more
terms
after
this
which
means
quite
a
lot
of
M
;M;M
TODO,
make
this
functional

#
(
define
(
addset
set
i
sets
smap
inher
)
(
aif
(
r
)
(
hashref
smap
set
#f
)
(
values
i
sets
smap
inher
)
(
let
((
j
i
)
(
i
(
*
2
i
)))
(
let
lp
((
sets
sets
)
(
ih
j
))
(
if
(
pair?
sets
)
(
let
((
sb
(
car
sets
)))
(
aaif
((
jj
(
hashref
settoi
set
#f
))
(
hh
(
hashref
settoinher
set
#f
))
(
jb
(
hashref
smap
sb
#f
))
(
jjb
(
hashref
settoi
sb
#f
))
(
hb
(
hashref
inher
sb
#f
))
(
hhb
(
hashref
settoinher
sb
#f
)))
(
when
(
>
(
logand
jj
hhb
)
0
)
(
hashset!
inher
sb
(
logior
hb
j
)))
(
when
(
>
(
logand
jjb
hh
)
0
)
(
set!
ih
(
logior
jb
ih
)))
(
lp
(
cdr
sets
)
ih
)))
(
begin
(
hashset!
smap
set
j
)
(
hashset!
inher
set
ih
)
(
values
j
(
cons
set
sets
)
smap
inher
)))))))
#

1
Find
individual
clusters

#
(
define
(
clusterize
sets
smap
)
(
let
((
sets
(
sort
sets
(
lambda
(
s1
s2
)
(
>
(
hashref
smap
s1
#f
)
(
hashref
smap
s2
#f
))))))
(
let
lp
((
ss
sets
))
(
if
(
pair?
ss
)
(
let
((
cluster
(
allinih
smap
(
car
ss
))))
(
cons
cluster
(
lp
(
difference
cluster
))))
'
()))))
(
define
(
mktree1
sets
smap
)
(
let
((
cls
(
clusterize
sets
smap
)))
(
map
(
lambda
(
cluster
)
cls
)
(
if
(
and
(
pair
cls
)
(
pair?
(
cdr
cls
)))
(
cons
(
car
cluster
)
(
mktree1
(
cdr
cluster
)
smap
))
(
if
(
null?
cluster
)
'
()
(
car
cluster
))))))
(
define
(
linearize
tree
)
(
let
lp
((
r
tree
))
(
match
r
((
x
.
y
)
(
append
(
linearize
x
)
(
lenearize
y
)))
(()
'
())
(
x
(
list
x
)))))
(
define
(
mktree2
l
)
(
define
(
divide
l
)
(
let
((
n
(
length
l
)))
(
case
n
((
0
)
(
values
#t
#f
#f
))
((
1
)
(
values
#t
(
car
x
)
#f
))
((
2
)
(
values
#t
(
car
x
)
(
cadr
x
)))
(
else
(
let
lp
((
l
l
)
(
i
0
)
(
r
'
())
(
k
(
/
n
2
)))
(
if
(
<
i
k
)
(
lp
(
cdr
l
)
(
+
i
1
)
(
cons
(
car
l
)
r
)
k
)
(
values
#f
(
reverse
r
)
l
)))))))
(
callwithvalues
(
lambda
()
(
divide
l
))
(
lambda
(
finish?
x
y
)
(
if
finish?
(
if
y
(
cons
x
y
)
x
)
(
cons
(
mktree2
x
)
(
mktree2
y
))))))
(
define
(
attachor
settoinh
settof
tree
)
(
define
(
mkf
set
)
(
hashref
settof
set
#f
))
(
define
(
mkh
h
)
(
logior
(

h
)
h
))
(
let
lp
((
tree
tree
))
(
match
tree
((
x
.
y
)
(
letvalues
(((
px
x
)
(
lp
x
))
((
py
y
)
(
lp
y
)))
(
values
(
cons
(
cons
px
x
)
(
cons
py
y
))
(
logior
px
py
))))
(
#f
(
values
#f
0
))
(
x
(
aif
(
h
)
(
hashref
settoinh
x
#f
)
(
let
((
h
(
mkh
h
)))
(
values
(
vector
h
(
mkf
x
)
x
)
h
))
e
)))))
(
define
(
add
tree
set
f
)
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