Fun with lists

09-04-2006, 09:27 AM

Infrane's list system got me looking back at some stuff I did while Weaaddar was around. I combined it with a few other things I've been working on for awhile and want to show the result as food for thought. First, a lisp style list system with some simple garbage collection:

JASS:

globals
//this heap is intended for lisp style pairs/lists
    integer array heapcar    //GC will chase pointers in car and cdr
    integer array heapcdr   //typically car is data and cdr is pointer to next element in list
    integer array heapaux    //you could put type information here
    boolean array heapinuse //for internal use in allocator
    boolean array heapcolor //for internal use in garbage collector
    boolean inusecolor = true
    boolean markedcolor = true
    integer hp        //top of the heap.  grows up from 1 (0 is "NULL")

    integer array stack    //pass variables and store locals on the stack
    integer sp = 0        //bottom of stack.  grows upward (not like x86)

    integer ret        //register for return values

endglobals

constant function HLEN takes nothing returns integer    //size of heap.  larger than this and garbage collector hits thread execution limit
    return 4096
endfunction

function gcmarkptr takes integer x returns nothing    //chases pointers and marks all nodes in the heap that can be seen.  cycle safe, as it breaks if it hits a node it has seen before.
    if x > 0 and x < HLEN() then
        if heapinuse[x] == inusecolor and heapcolor[x] != markedcolor then
//			call BJDebugMsg("marked "+I2S(x))
            set heapcolor[x] = markedcolor
            call gcmarkptr(heapcar[x])
            call gcmarkptr(heapcdr[x])
        endif
    endif
endfunction

//conservative mark algorithm.  we could tell it what a pointer is, but not much point.
function gcmark takes nothing returns nothing    //chase all accessible pointers.  use the stack and ret as the base set.
    local integer i = 0
//	call BJDebugMsg("marking")
    loop
        exitwhen i >= sp
        call gcmarkptr(stack[i])
        set i = i + 1
    endloop
    call gcmarkptr(ret)
endfunction

function gcsweep takes nothing returns nothing    //Everything that wasn't seen on the mark phase can be set to free
    local boolean notinusecolor = not inusecolor
    local boolean notmarkedcolor = not markedcolor
    local integer n = 0
    local integer i = 0
//	call BJDebugMsg("sweeping")
    loop
        exitwhen i >= HLEN()
        if heapcolor[i] != markedcolor and heapinuse[i] == inusecolor then
//			call BJDebugMsg("swept "+I2S(i))
            set heapinuse[i] = notinusecolor
            set n = n + 1
        endif
        set heapcolor[i] = notmarkedcolor
        set i = i + 1
    endloop
    call BJDebugMsg("swept "+I2S(n))
    set hp = 1
endfunction

//stop-the-world mark and sweep
function gccollect takes nothing returns nothing
    call ExecuteFunc("gcmark")
    call ExecuteFunc("gcsweep")
endfunction

//scan through heap until a free pair is found
//if it hits the end, triggers a garbage collection cycle
function heapalloc takes nothing returns integer
    loop
        set hp = hp + 1
        if hp >= HLEN() then
            call gccollect()
        endif
        exitwhen heapinuse[hp] != inusecolor
    endloop
    set heapinuse[hp] = inusecolor
    return hp
endfunction

function cons takes integer x, integer y returns integer
    local integer pair = heapalloc()
    set heapcar[pair] = x
    set heapcdr[pair] = y
    return pair
endfunction
function car takes integer pair returns integer
    return heapcar[pair]
endfunction
function cdr takes integer pair returns integer
    return heapcdr[pair]
endfunction

function init takes nothing returns nothing
    set hp = 1
endfunction
function push takes integer x returns nothing
    set stack[sp] = x
    set sp = sp + 1
endfunction

In order to make this work, the garbage collector needs to know about all the local variables in the program. Otherwise it will have no idea what is visible. So this requires a rather bizarre style of coding. For example, computing fibonacci numbers:

JASS:

function fibonacci_helper takes nothing returns nothing
    local integer fp = sp
    if(stack[fp-2] <= 1) then
        set ret = cdr(stack[fp-1])
    else
        call push(stack[fp-2]-1)
        call push(cons(cdr(stack[fp-1]),car(stack[fp-1])+cdr(stack[fp-1])))
        call fibonacci_helper()        //arrrrr, this be a tailcall
        set sp = sp - 2
    endif
endfunction

function fibonacci takes nothing returns nothing
    local integer fp = sp
    call push(stack[fp-1])
    call push(cons(0,1))
    call fibonacci_helper()
    set sp = sp - 2
endfunction

This could be made a little simpler by moving function arguments that aren't cons pairs to regular function arguments, but this demonstrates the technique. While it looks ugly, it is actually not that bad. The use of the "fp" variable puts all local variables/function arguments in static places:
function argument 1 -> fp-1
function argument 2 -> fp-2
function argument n -> fp-n
local var 1 -> fp
local var 2 -> fp+1
local var n -> fp+n-1
Statically compiling this into names could be done with just text replacement. It's also not "that" slow as it only roughly doubles to triples the function calling overhead.

Here's merge sort, an algorithm that demonstrates the use of fp for locals:

JASS:

//Calling convention:  caller cleans the stack
function split takes nothing returns nothing
    local integer fp = sp            //frame pointer
    local integer list = stack[fp-1]
    set sp = sp + 2                //move stack up for room for two local variables
    set stack[fp] = 0        //local 1 - left list
    set stack[fp+1] = 0        //local 2 - right list
    loop
        exitwhen list == 0    //0 is list terminator/null pointer
        set stack[fp] = cons(car(list),stack[fp])
        set list = cdr(list)
        exitwhen list == 0
        set stack[fp+1] = cons(car(list),stack[fp+1])
        set list = cdr(list)
    endloop
    set ret = cons(stack[fp],stack[fp+1])    //return two values by consing them together
    set sp = sp - 2
endfunction

//returns one integer
function merge takes nothing returns nothing
    local integer fp = sp
    local integer left = stack[fp-2]
    local integer right = stack[fp-1]
    if left == 0 then
        set ret = right
    elseif right == 0 then
        set ret = left
    elseif car(left) >= car(right) then
        call push(cdr(left))    //function calling:  push arguments in reverse order
        call push(right)
        call merge()
        set ret = cons(car(left),ret)
        set sp = sp - 2        //pop() twice to clean stack
    else
        call push(left)
        call push(cdr(right))
        call merge()
        set ret = cons(car(right),ret)
        set sp = sp - 2
    endif
endfunction

function sort takes nothing returns nothing
    local integer fp = sp
    local integer list = stack[fp-1]
    if list == 0 or cdr(list) == 0 then
        set ret = list
    else
        set sp = sp + 2        //make space for two local variables

        call push(list)        //(left,right) = split(list)
        call split()
        set stack[fp] = car(ret)
        set stack[fp+1] = cdr(ret)
        set sp = sp - 1

        call push(stack[fp])     //left = sort(left)
        call sort()
        set stack[fp] = ret
        set sp = sp - 1

        call push(stack[fp+1])    //right = sort(right)
        call sort()
        set stack[fp+1] = ret
        set sp = sp - 1

        call push(stack[fp])    //return merge(left,right)
        call push(stack[fp+1])
        call merge()
        set stack[fp] = ret
        set sp = sp - 2

        set ret = stack[fp]    //That merge was a tailcall

        set sp = sp - 2     //let go of space for local vars
    endif
endfunction

another example similar to fibonacci, reverse list:

JASS:

function reverse_helper takes nothing returns nothing //reverse_helper(list,result)
    local integer fp = sp
    if stack[fp-2] == 0 then
        set ret = stack[fp-1]        //return result
    else
        call push(cdr(stack[fp-2]))    //call reverse_helper(rest(list),cons(car(list),result)
        call push(cons(car(stack[fp-2]),stack[fp-1]))
        call reverse_helper()
        set sp = sp - 2
    endif
endfunction

function reverse takes nothing returns nothing
    local integer fp = sp
    call push(stack[fp-1])            //call reverse_helper(list,null)
    call push(0)
    call reverse_helper()
    set sp = sp - 2
endfunction

and some testing code which shows off the garbage collector doing its thing by sorting a bunch of lists and displaying them

JASS:

function listprint takes string msg, integer l returns nothing
    local string s = ""
    loop
        exitwhen l == 0
        set s = I2S(car(l)) + " " + s
        set l = cdr(l)
    endloop
    call BJDebugMsg(msg+s)
endfunction

function testsort takes nothing returns nothing
    local integer fp = sp
    local integer i = 0
    set sp = sp + 3
    set stack[fp] = 0
    loop
        exitwhen i >= 20
        set stack[fp] = cons(GetRandomInt(0,50),stack[fp])
        set i = i + 1
    endloop

    call push(stack[fp])
    call sort()
    set sp = sp - 1
    call push(ret)
    call reverse()
    set sp = sp - 1
    call listprint("end: ",ret)

    set sp = sp - 3
endfunction

function test takes nothing returns nothing
    //merge sort and reverse
    local integer i = 0
    loop
        exitwhen i>=100
        call testsort()
        call BJDebugMsg("sp: "+I2S(sp)+" hp: "+I2S(hp))
        call TriggerSleepAction(0.)
        set i = i + 1
    endloop

    //weird fibonacci
    call push(10)
    call fibonacci()
    set sp = sp - 1
    call BJDebugMsg(I2S(ret))
endfunction

09-04-2006, 08:53 PM	#2
BertTheJasser	Omg

09-04-2006, 09:21 PM	#3
Zoxc	I missed the fun, didn't I?

09-05-2006, 02:17 AM

PipeDream

The fun is in how easy it is to toss together things. One thing it excels at is expressions. For example, home grown boolean expressions become trivial:

JASS:

constant function leaftype takes nothing returns integer
    return 1 
endfunction
constant function andtype takes nothing returns integer
    return 2 
endfunction
constant function ortype takes nothing returns integer
    return 3
endfunction
constant function nottype takes nothing returns integer
    return 4
endfunction
constant function xortype takes nothing returns integer
    return 5
endfunction

function makeand takes integer x, integer y returns integer
    return cons(andtype(),cons(x,y))
endfunction
function makeor takes integer x, integer y returns integer
    return cons(ortype(),cons(x,y))
endfunction
function makeleaf takes integer var returns integer
    return cons(leaftype(),var)
endfunction
function makenot takes integer x returns integer
    return cons(nottype(),x)
endfunction
function makexor takes integer x, integer y returns integer
    return cons(xortype(),cons(x,y))
endfunction

function gettype takes integer tree returns integer
    return car(tree)
endfunction
function getsingle takes integer tree returns integer
    return cdr(tree)
endfunction
function getleft takes integer tree returns integer
    return car(cdr(tree))
endfunction
function getright takes integer tree returns integer
    return cdr(cdr(tree))
endfunction

function evaltree takes integer tree returns boolean
    local integer t = gettype(tree)
    if t == leaftype() then
        return vars[getsingle(tree)]
    elseif t == ortype() then
        return evaltree(getleft(tree)) or evaltree(getright(tree))
    elseif t == andtype() then
        return evaltree(getleft(tree)) and evaltree(getright(tree))
    elseif t == nottype() then
        return not evaltree(getsingle(tree))
    elseif t == xortype() then    
        return evaltree(getleft(tree)) != evaltree(getright(tree))
    endif
    return false
endfunction

function setupeval takes nothing returns nothing
    set varn = -1 
endfunction
function newvar takes nothing returns integer
    set varn = varn + 1
    return varn
endfunction

function BS takes boolean b returns string
    if b then
        return "true"
    else
        return "false"
    endif
endfunction

function testeval takes nothing returns nothing
    local integer fp = sp
    local integer var1 = 1
    local integer var2 = 2
    local integer var3 = 3
    set sp = sp + 1
    set stack[fp] = makeand(makeor(makeleaf(var1),makeleaf(var2)),makenot(makeleaf(var3)))
    
    set vars[var1] = false
    set vars[var2] = true
    set vars[var3] = true
    call BJDebugMsg(BS(evaltree(stack[fp])))
    set vars[var3] = false
    call BJDebugMsg(BS(evaltree(stack[fp])))
endfunction

Or symbolic expressions, although the lack of a good type system starts to hurt. I've forgone the garbage collection helper stuff for readability. The routine for taking derivatives is less than 20 lines!

JASS:

function numtype takes nothing returns integer
    return 1
endfunction
function symtype takes nothing returns integer
    return 2
endfunction
function isexpr takes integer node returns boolean
    return gettype(node) > 2
endfunction
function sumtype takes nothing returns integer
    return 3
endfunction
function multype takes nothing returns integer
    return 4
endfunction

function makenum takes integer x returns integer
    return cons(numtype(),x)
endfunction
function makesym takes integer x returns integer
    return cons(symtype(),x)
endfunction
function makesum takes integer x, integer y returns integer
    return cons(sumtype(),cons(x,y))
endfunction
function makemul takes integer x, integer y returns integer
    return cons(multype(),cons(x,y))
endfunction
    
function printexpr takes integer expr returns string
    if gettype(expr) == numtype() then
        return I2S(cdr(expr))
    elseif gettype(expr) == symtype() then
        return "x"
    elseif gettype(expr) == sumtype() then
        return "("+printexpr(getleft(expr))+"+"+printexpr(getright(expr))+")"
    elseif gettype(expr) == multype() then
        return "("+printexpr(getleft(expr))+"*"+printexpr(getright(expr))+")"
    endif
    return "?"
endfunction

function deriv takes integer expr, integer var returns integer
    if gettype(expr) == numtype() then
        return makenum(0)
    elseif gettype(expr) == symtype() then
        if getsingle(expr) == var then
            return makenum(1)
        else
            return makenum(0)
        endif
    elseif gettype(expr) == sumtype() then
        return makesum(deriv(getleft(expr),var),deriv(getright(expr),var))
    elseif gettype(expr) == multype() then
        return makesum(makemul(deriv(getleft(expr),var),getright(expr)),makemul(getleft(expr),deriv(getright(expr),var)))
    endif
    call BJDebugMsg("error, unknown type in deriv")
    return 0
endfunction

function testexpr takes nothing returns nothing
    local integer fp = sp
    set sp = sp + 1
    set stack[fp] = makesum(makemul(makenum(3),makesym(0)),makesum(makenum(2),makesym(0)))
    call BJDebugMsg(printexpr(stack[fp]))
    call BJDebugMsg(printexpr(deriv(stack[fp],0)))
endfunction

Writing evaluate for this is no harder than it is for the boolean expressions. With another 50 lines for simplifying expressions it might even be useful.

09-05-2006, 02:46 AM	#5
Vexorian	hmn when I read con and cdr it reminds me that I didn't really learn LISP the last time even though I did use it to make a homework and get the best grade in that class.

09-05-2006, 07:10 AM

Anitarf

Quote:

Originally Posted by PipeDream

With another 50 lines for simplifying expressions it might even be useful.

Oh, good, I was starting to fear that due to my lack of programming knowledge I was mission out on something important in this thread. :)

09-05-2006, 09:22 PM	#7
PitzerMike	Yeah, atm this is, erm, interesting for programmers at best :) But it's fun to play around with. goes to think of a way to use this

09-05-2006, 09:36 PM	#8
Vexorian	Reminds me the time when I made the pool class and didn't know where to use it.