Einzelpasslinse für die Wurzel eines ausgeglichenen Binärbaum

Question

Ich habe einen ausgeglichenen binären Baum, der Baum der Tiefe in seiner Art umfasst:

data Nat = Zero | Succ Nat 
data Tree (n :: Nat) a where 
    Leaf :: Tree Zero a 
    Branch :: a -> (Tree n a, Tree n a) -> Tree (Succ n) a 

ich einen Weg möchten beliebige Funktionen f :: Tree n a -> Tree n a auf der Unterstruktur laufen der Tiefe n an der Wurzel irgendeines Tree m a, m ≥ n.

ich in der Lage war, diese eine Möglichkeit, eine Typklasse zum Extrahieren und Ersetzen des Wurzelunterbaumes zu implementieren mit:

mapRoot :: X m n => (Tree n a -> Tree n a) -> Tree m a -> Tree m a 
mapRoot f t = putRoot (f (getRoot t)) t 

class X m n where 
    getRoot :: Tree m a -> Tree n a 
    putRoot :: Tree n a -> Tree m a -> Tree m a 

instance X m Zero where 
    getRoot t = Leaf 
    putRoot Leaf t = t 

instance X m n => X (Succ m) (Succ n) where 
    getRoot (Branch a (l,r)) = (Branch a (getRoot l, getRoot r)) 
    putRoot (Branch a (l,r)) (Branch _ (l',r')) = Branch a (putRoot l l', putRoot r r') 

Während dies funktioniert, bedarf es zwei Durchgänge durch den Wurzelunterbaum, und ich möchte um es in einem zu tun, wenn möglich.

Dies ist fast möglich durch faule Auswertung mit (den Bund fürs Leben):

mapRoot' :: Y m n => (Tree n a -> Tree n a) -> Tree m a -> Tree m a 
mapRoot' f t = t' where 
    (r, t') = swapRoot t r' 
    r' = f r 

class Y m n where 
    swapRoot :: (Tree m a, Tree n a) -> (Tree n a, Tree m a) 

instance Y m Zero where 
    swapRoot t leaf = (leaf, t) 

instance Y m n => Y (Succ m) (Succ n) where 
    swapRoot (Branch a (l,r)) (Branch a' (l',r')) = (Branch a (lx,rx), Branch a' (lx',rx')) where 
    (lx,lx') = swapRoot l l' 
    (rx,rx') = swapRoot r r' 

Aber wenn Sie tatsächlich versuchen, mapRoot' laufen Sie feststellen, dass es nicht zu stoppen; Das liegt daran, dass swapRoot in seinem zweiten Argument nicht faul ist (was nicht sein kann, weil Tree n a eine GADT ist).

jedoch gegeben getRoot und putRoot habe ich eine Linse für die Root-Teilstruktur bekommt, die ich führt zu vermuten, es gibt andere, darunter eine, die verwendet werden kann, mapRoot in einem einzigen Durchgang zu implementieren.

Was ist ein solches Objektiv?

Answer 1

Ihr Ansatz, den Knoten zu knüpfen, ist ein guter Klang - Sie brauchen nur alle Parameter an der richtigen Stelle, damit die Funktion ausreichend faul ist.

data (:<=) (n :: Nat) (m :: Nat) where 
    LTEQ_0 :: 'Zero :<= n 
    LTEQ_Succ :: !(n :<= m) -> 'Succ n :<= 'Succ m 

mapRoot :: n :<= m -> (Tree n a -> Tree n a) -> Tree m a -> Tree m a 
mapRoot p0 f0 t0 = restore (f0 root) where 
    (root, restore) = go p0 t0 

    go :: n :<= m -> Tree m a -> (Tree n a, Tree n a -> Tree m a) 
    go LTEQ_0 t = (Leaf, const t) 
    go (LTEQ_Succ p) (Branch a (l,r)) = 
    case (go p l, go p r) of 
     ((l', fl), (r', fr)) -> 
     (Branch a (l', r') 
     , \(Branch a1 (l1, r1)) -> Branch a1 (fl l1, fr r1) 
     ) 

anzumerken, dass go kehrt ein Paar - der Wurzelbaum, und eine Funktion des verarbeiteten Wurzel zu nehmen und um das Ergebnis zurück. Dies macht es explizit (zum Programm und zur Laufzeit!), Dass die resultierende Tree n a nicht von der Eingabe Tree n a abhängt.

Außerdem habe ich Ihre Klasse mit einem GADT nur der Kürze wegen ersetzt.