Binary.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Pandora.Paradigm.Structure.Binary (Binary, insert) where

import Pandora.Core.Functor (type (:.), type (:=))
import Pandora.Core.Morphism ((&), (%), (!))
import Pandora.Pattern.Category ((.))
import Pandora.Pattern.Functor.Covariant (Covariant ((<$>)))
import Pandora.Pattern.Functor.Extractable (extract)
import Pandora.Pattern.Functor.Divariant (($))
import Pandora.Pattern.Object.Chain (Chain ((<=>)))
import Pandora.Paradigm.Primary.Object.Ordering (order)
import Pandora.Paradigm.Primary.Functor.Maybe (Maybe (Just, Nothing), maybe)
import Pandora.Paradigm.Primary.Functor.Product (Product ((:*:)))
import Pandora.Paradigm.Primary.Functor.Wye (Wye (End, Left, Right, Both))
import Pandora.Paradigm.Primary.Functor.Tagged (Tagged (Tag))
import Pandora.Paradigm.Primary.Transformer.Construction (Construction (Construct), deconstruct)
import Pandora.Paradigm.Controlflow.Joint.Schemes.TU (TU (TU))
import Pandora.Paradigm.Controlflow.Joint.Interpreted (run)
import Pandora.Paradigm.Inventory.Store (Store (Store))
import Pandora.Paradigm.Inventory.Optics ((%~))
import Pandora.Paradigm.Structure.Ability.Nonempty (Nonempty)
import Pandora.Paradigm.Structure.Ability.Focusable (Focusable (Focus, top, singleton))
import Pandora.Paradigm.Structure.Ability.Substructure (Substructure (Substructural, sub))

type Binary = TU Covariant Covariant Maybe (Construction Wye)

insert :: Chain a => a -> Binary a -> Binary a
insert x (TU Nothing) = TU . Just . Construct x $ End
insert x tree@(TU (Just (Construct y _))) = x <=> y & order
	(sub @Left %~ (insert x <$>) $ tree) tree
	(sub @Right %~ (insert x <$>) $ tree)

rebalance :: Chain a => (Wye :. Construction Wye := a) -> Nonempty Binary a
rebalance (Both x y) = extract x <=> extract y & order
	(Construct (extract y) $ Both x (rebalance $ deconstruct y))
	(Construct (extract x) $ Both (rebalance $ deconstruct x) (rebalance $ deconstruct y))
	(Construct (extract x) $ Both (rebalance $ deconstruct x) y)

instance (forall a . Chain a) => Focusable Binary where
	type Focus Binary a = Maybe a
	top (TU Nothing) = Store . (:*:) Nothing $ TU . (<$>) (Construct % End)
	top (TU (Just x)) = Store . (:*:) (Just $ extract x) $ maybe
		(TU . Just . rebalance $ deconstruct x)
		(TU . Just . Construct % deconstruct x)
	singleton = TU . Just . Construct % End

instance Substructure Left Binary where
	type Substructural Left Binary a = Binary a
	sub (TU Nothing) = Store $ (:*:) (Tag $ TU Nothing) $ (TU Nothing !)
	sub t@(TU (Just (Construct x End))) = Store $ (:*:) (Tag $ TU Nothing) $
		maybe t (TU . Just . Construct x . Left) . run . extract
	sub (TU (Just (Construct x (Left lst)))) = Store $ (:*:) (Tag . TU . Just $ lst) $
		maybe (TU . Just . Construct x $ End) (TU . Just . Construct x . Left) . run . extract
	sub t@(TU (Just (Construct x (Right rst)))) = Store $ (:*:) (Tag $ TU Nothing) $
		maybe t (TU . Just . Construct x . Both % rst) . run . extract
	sub (TU (Just (Construct x (Both lst rst)))) = Store $ (:*:) (Tag . TU . Just $ lst) $
		maybe (TU (Just (Construct x (Right rst)))) (TU . Just . Construct x . Both % rst) . run . extract

instance Substructure Right Binary where
	type Substructural Right Binary a = Binary a
	sub (TU Nothing) = Store $ Tag (TU Nothing) :*: (TU Nothing !)
	sub t@(TU (Just (Construct x End))) = Store $ Tag (TU Nothing)
		:*: maybe t (TU . Just . Construct x . Right) . run . extract
	sub t@(TU (Just (Construct x (Left lst)))) = Store $ Tag (TU Nothing)
		:*: maybe t (TU . Just . Construct x . Both lst) . run . extract
	sub (TU (Just (Construct x (Right rst)))) = Store $ (Tag . TU . Just $ rst)
		:*: maybe (TU . Just . Construct x $ End) (TU . Just . Construct x . Right) . run . extract
	sub (TU (Just (Construct x (Both lst rst)))) = Store $ (Tag . TU . Just $ rst)
		:*: maybe (TU . Just . Construct x $ Left lst) (TU . Just . Construct x . Both lst) . run . extract

type instance Nonempty Binary = Construction Wye

instance Focusable (Construction Wye) where
	type Focus (Construction Wye) a = a
	top (Construct x xs) = Store $ x :*: Construct % xs
	singleton = Construct % End

instance Substructure Left (Construction Wye) where
	type Substructural Left (Construction Wye) a = Maybe :. Construction Wye := a
	sub (Construct x End) = Store $ Tag Nothing :*: (Construct x End !)
	sub (Construct x (Left lst)) = Store $ Tag (Just lst)
		:*: maybe (Construct x End) (Construct x . Left) . extract
	sub tree@(Construct x (Right rst)) = Store $ Tag Nothing
		:*: maybe tree (Construct x . Both % rst) . extract
	sub (Construct x (Both lst rst)) = Store $ Tag (Just lst)
		:*: maybe (Construct x $ Right rst) (Construct x . Both % rst) . extract

instance Substructure Right (Construction Wye) where
	type Substructural Right (Construction Wye) a = Maybe :. Construction Wye := a
	sub (Construct x End) = Store $ Tag Nothing :*: (Construct x End !)
	sub tree@(Construct x (Left lst)) = Store $ Tag Nothing
		:*: maybe tree (Construct x . Both lst) . extract
	sub (Construct x (Right rst)) = Store $ Tag (Just rst)
		:*: maybe (Construct x End) (Construct x . Right) . extract
	sub (Construct x (Both lst rst)) = Store $ Tag (Just rst)
		:*: maybe (Construct x $ Left lst) (Construct x . Both lst) . extract