Lambda the Ultimate

Is this code I just wrote a solution to "the problem of testing the balance of a Calder mobile in a single traversal", or did I miss something else? If the tagging and untagging with Just is undesired, one can Church-encode the Maybe type into continuation-passing or exception-throwing code...

I'd like to see even more puzzles.

Yes, that looks about right. I said it was easy! The relevance to programming languages is that there are some nice ways of deriving and relating the different solutions that involve continuations.

I believe Danvy has discussed this problem in a number of places. This note (in French) is dedicated to it: Sur un exemple de Patrick Greussay, http://www.brics.dk/RS/04/41/BRICS-RS-04-41.pdf.

f(0) = 0

f(n) = 1 + p * f(n-1) + (1-p) * f(n+1)

f(2) = 2f(1).

In your solution, I believe you are counting those where you go up 2 steps then fall back down 1, to get up a step. But any implementation would have stopped already! So you get infinitely many solutions because you look at all those possible futures.

Eric Bodden wrote:
``You have a simple linked list with more than 15 elements and should
return from it the 15th element. And don't even dare thinking about
iterating the list twice!''

As others noted, you probably mean the 15th element from the end. The
problem doesn't seem to be too hard; it can be solved in constant
space. I guess the trick is to traverse the same list using two
pointers, one of them is suitably delayed.

-- Nth element of the list, from the end, assuming the list is longer
-- than n.
lastN n lst = loop lst (drop n lst)
 where loop (h0:_) [] = h0
       loop (_:t0) (_:t1) = loop t0 t1


test1 = lastN 15 (reverse [1..30])
test2 = lastN 15 [1..100]

This is just the generalization of Haskell's standard function `last'.

Your function loop is equivalent to \xs ys -> last (zipWith const xs ys).

You are off by one.

module Prune where

data LTree a = Leaf String a | Branch String [LTree a]
    deriving (Eq, Show)

-- A simple solution
prune :: (a -> Bool) -> LTree a -> Maybe (LTree a)
prune pred tree@(Leaf _ a)
    = if pred a then Just tree else Nothing
prune pred (Branch label branches)
    = if null pruned then Nothing else Just (Branch label pruned)
    where pruned = [ branch | Just branch <- map (prune pred) branches ]

-- For testing
binary :: Int -> Int -> LTree Int
binary n k = if k > 0 then Branch bit [binary n' k', binary (succ n') k']
                      else Leaf bit n
    where bit = show (n `mod` 2)
	  n' = n + n
	  k' = pred k

This is indeed an interesting problem; it is also the excellent
illustration of `stack marks' or stack traversal facility described in
the paper `Delimited dynamic binding' (see, in particular Section 6.2
of the paper and the `nub' example). The OCaml code of the solution
is available here


http://pobox.com/~oleg/ftp/ML/pruned-tree-outline.ml


assuming the Dynvar library introduced in that paper, and whose source
is available from that web site. The source code contains a few tests
and their output. Posting a lot of source code at LtU
doesn't seem suitable (nor appropriate).

It is easy to see that the problem can indeed be solved without any
heap allocation, requiring only O(tree-depth) stack space -- provided
that Dynvar library (actually, the underlying shift/reset
implementation were a bit smarter -- like that in Chez Scheme).

I've posted two K solutions to this clever little problem here:

Subtree where leaf x is f x

Solution 1 is what I would call "semi-recursive". Here's the idea. We represent a tree with a nested dictionary, which is one of K's recursive datatypes (the other being a general list.) Then (recursive part) we compute a list of paths to the leaves. From here we proceed non-recursively to (i) extract the data at the leaves as a vector, (ii) apply the predicate to the vector (an array operation, which returns a boolean vector), and (iii) construct a new dictionary consisting of just those paths to leaves which satisfy the predicate.

Solution 2 is non-recursive, and uses a more economical representation of a tree as three equal-length vectors: T, where T[i]=j means that node i is a child of node j (T[0] = 0 = the root of the tree); D, where D[i] = the data at leaf i (if i is not a leaf, then D[i] is NaN); and N, where N[i] = the label of node i.

Solution 2 is presented as "open code": t, d, and n together represent the input tree, f is the predicate, and T, D, and N represent the output subtree. (Wrapping the code in a function is trivial, but I assume that readers who execute the solution will want to examine the intermediate values.)

Solution 1 is shorter, and probably easier to understand. (well ...) It was certainly easier to write, being quasi-idiomatic, and familiar to all seasoned k programmers. Probably no more than 10 minutes work, most of which went towards the nasty-looking (recursive) pretty-printer (and the comments).

Solution 2 contains a few subtleties, and required more time and testing to get right. But solution 2 scales quite well. I invite others to test their implementations on larger trees having varying width/depth. e.g. 500,000 nodes, 10,000 of which are leaves.

Note added. I've included a fully recursive solution for comparison:

st:{(./)._n,+{:[5=4:z;,/_f'[x,/:!z;y;z[]];y z;,(x;:;z);()]}[();y;x]}

st descends until it finds a leaf z. Where y is the predicate, if y z is true, st returns (x;:;z), where x is the path to z. If y z isn't true, st returns null. The result is amended to produce the desired subtree.

Note added. I've also included a non-recursive K4 solution, which is half the code of the K2 version.

And finally, a solution in the Q dialect of K4:

select from t where n in 
  raze({exec p from t where n in x}scan)each 
  exec n from t where f d

Further details in the paper linked above.

Here's a cute little Haskell solution:

josephus init nth = last alive
   where
   alive = init ++ kill (length init) alive
   
   kill    0  line = []
   kill (n+1) line = take (nth-1) line ++ kill n (drop nth line)

Then you can solve the canonical problem instance by calculating, e.g.

josephus [1..40] 3

http://paste.lisp.org/display/31383

That looks like one pass to me.

...when the going gets tough, this'll blow the stack. (Cue "The Importance of TCO" from Anton...)

It's non-deterministic by nature of the problem, but if the first recursive call succeds it's just as likely the second one will too. So, your point was?

As the success probability of step() goes down, the expected number of times we'll need to call it goes up (see recurrence analyses above). In this implementation (as in others) step() is called once per call to step_up(), so the expected number of calls to step() is related (though not identical to) the expected stack depth. (Another interesting exercise might be to precisely characterize this relationship.) In any case, if the success probability is low enough, this Java code will certainly result in a StackOverflowError.

The point of this was that the equivalent Scheme code (linked from one of the first comments above) is guaranteed not to suffer from this problem (since Scheme implementations are required to execute tail calls in constant space). However, now that I think about it more carefully, I realize that I was wrong about this. TCO doesn't matter in this case, as the first recursive call is not in tail position. So the Scheme version will also likely run out of space sooner than a version using a loop and explicit counter. Perhaps this is what you meant... I'm having a little trouble understanding your comment.

TCO is a very useful tool. Another excellent and underappreciated tool is a very big stack, i.e. being able to shove a heap worth of stuff onto your stack when it suits you.

For example, here is the standard non-tail-recursive map function in Erlang's lists module:

map(F, [H|T]) ->
    [F(H)|map(F, T)];
map(F, []) when is_function(F, 1) -> [].

and here's mapping over a million-element list:

6> L = lists:seq(1, 1000000), ok.        
ok
7> lists:map(fun(X) -> X + 1 end, L), ok.
ok

No fuss no muss. But try it in your language!

My language Kogut handles large stacks just fine. They are silently resized on overflow, silently shrunk by GC, and they aren't scanned as a whole by minor GC.

Perhaps this is what you meant... I'm having a little trouble understanding your comment.

Yes, that's what I meant. Even in a language without tail call optimization, if the first recursive call - which is not in tail position - succeeds, its just as likely that the second recusive call - which is in tail position - also does.

void stepup ()
{
       while (!step()) {
              stepup();
       }
}

Now 50% better!

If it falls 1 step, it should go up 2 steps.

Notice the while loop. Yes, I know, it's not natural!

This version consumes stack space proportional to the number of steps it needs to go up, as opposed to the number of steps it attempts. This is a substantial difference if the probability of success is only somewhat greater than or equal to 1/2.

Unfortunately, sometimes the attempt fails and the robot clumsily falls one step instead.

For every return of false by step(), the number of needed successful calls to step() increments.

procedure step_up;
var
  level: integer;
begin
  level := -1;
  while level < 0 do
    if step then
      inc(level) else
        dec(level);
end;

or with standard tail-recursion:

procedure step_up_from(level: integer);
begin
  if level = 0 then exit;

  if step then
    step_up_from(level+1) else
      step_up_from(level-1);
end;

I would generally not assume that the robot will never fall twice in a row, since the problem does not say that it never will. There's no guarantees of the sort in real life.

pkhuong's code is correct, even if the robot steps down twice in a row..

As for the stack consumed, I would say that it is proportional to the "maximum" number of failed step up.

I didn't realize he used a while() instead of an if().

void step_up() {
while( !step() ){
step_up();
}
}

yes stack overflow is a problem, but then so is battery life, so forget about it.

I have a nice solution to this using the function 'loeb' I defined here. 'loeb' is a cycle fixing function that can be used with all kinds of containers. (The type of 'loeb' corresponds to that of Loeb's theorem in the modal logic GL). So here's a solution (minus the parser):


import Maybe

loeb :: Functor a => a (a x -> x) -> a x
loeb x = fmap (\a -> a (loeb x)) x

data Dict a = Dict { unDict :: [(String,a)] } deriving Show

instance Functor Dict where
fmap f (Dict ((a,b):abs)) = Dict ((a,f b):unDict (fmap f (Dict abs)))
fmap f (Dict []) = Dict []

f +++ g = \x -> f x ++ g x

get a (Dict b) = fromJust $ lookup a b

test = loeb (Dict [("a",const "x"+++get "b"),("b",const "y"+++get "a")])

Note how the argument to 'loeb' isn't circular, so it's easy to produce from a parser. In this case I'm solving:


define a x *b
define b y *a


(The cool thing is that I'd been hunting for an application of 'loeb' and now I have one, a practical one even.)

Cool! Your post inspired me to see if it's possible to encode the same solution in OCaml. Indeed it is, provided you have a (lazy enough) implementation of lazy lists. In this case, Run is a naive implementation of catenable lists, with thunked constructors. Encoding Haskell type classes as ML Functors:

module type FUNCTOR = sig
  type 'a t
  val map : ('a -> 'b) -> ('a t -> 'b t)
end

module Loeb (F : FUNCTOR) = struct
  let rec loeb x = F.map (fun a -> a (lazy (loeb x))) x
end

module Dict = struct
  type 'a t = (string * 'a) list
  let map f (d:'a t) : 'b t =
    List.map (fun (a, b) -> a, f b) d
  let get x (d:'a t) = List.assoc x d
end

(* define var = lit (lit|var)+ *)
let parse d =
  let compile l env =
    List.fold_right (fun e r ->
    let tail () = r in match e with
    | `Lit c -> Run.cons c tail
    | `Var w -> Run.append (fun () -> Dict.get w (Lazy.force env)) tail)
      l Run.Nil
  in
  let module L = Loeb(Dict) in
  L.loeb (Dict.map compile d)

As you remarked, the compilation proceeds from an absolutely flat representation. Note that I had to control the depth of evaluation in Loeb, and force the promise in the application code, as required. The result:

# let test = parse [
  "a", [`Lit 'x'; `Var "b"];
  "b", [`Lit 'y'; `Var "a"];
]  ;;
val test : char Run.t Dict.t =
  [("a", Run.Cons ('x', <lazy>)); ("b", Run.Cons ('y', <lazy>))]
# Run.take 6 (Dict.get "a" test) ;;
- : char list = ['x'; 'y'; 'x'; 'y'; 'x'; 'y']

If we can assume an lcons that evaluates its car and cdr lazily, here is one that can work (in pseudo-but-nearly-valid-scheme) -

; A step function which fails 50% of the time.
(define (step) 
    (if (= 0 (rand 2)) 
        (begin (display "DOWN") #f) 
        (begin (display "UP") #t)))
 
; Gets the second element of a list s,
; forcing the value of the first element if
; the list happens to be lazy.       
(define (forced-next s) (first s) (first (rest s)))

; (steps) generates a sequence of
; successful upward steps. To climb N steps,
; just take N elements from (steps).
(define (steps)
    (lcons (if (step)
                #t
                (forced-next (rest (steps))))
           (steps)))

I don't think this is stack safe, but what the heck, laziness is cool :)

It is not terribly difficult to implement lazy-cons in R⁵RS, using syntax-rules and lambdas...

I should be able to express it using delay and force, but ... I'm too lazy :)

Thanks for resurrecting the thread. I hadn't seen it and it's neat.

I'm not sure that you can really call for a solution "not using variables or numbers." By a diagonalization argument you can show that the problem can't be solved by any finite state automata -- you need at least a stack machine. You have to encode an arbitrary non-negative integer in mutable (or infinitely extensible) state, one way or another.

So, I would hope a student who gave a well presented diagonalization or similar argument could get nearly full credit, with extra credit if the student also gives the "but this is the answer you were looking for" solution.

-t

How about:

S := true | false S S

So that FFTTFTFTT is also possible.
Direct transliteration of the Java if-based code.
The while-based code would be:

S := true | { false S }

Sorry, that's wrong, should have been:

S := { false S } true

I tried to transform the (1) to (2) and back:
(1) S ::= t | f S S
(2) S ::= { f S } t

From (1) to (2) we can "rewrite" the last S:
(3) S ::= t | f S t | f S f S S
(4) S ::= t | f S t | f S f S t | f S f S f S S
The last S will eventually rewrite to t, so we can express it as:
(2) S ::= { f S } t
This can actually be "done" mechanically and I guess that's how the tail recursion is transformed to a cycle.

The (2) to (1) way, if we apply the definition of { }:
(5) S ::= A t
(6) A ::= eps | f S A
If we substitute the A in (5):
(7) S ::= t | f S A t
But the last "A t" in (7) is what S in (5) rewrites to, so we can, hmm, write it as:
(1) S ::= t | f S S
This way doesn't seem to be so "mechanizable". But who wants to transform a cycle to a recursion.