[Runtime] Added delegate so user can control behavior of File() and FPathName(). Register new function with RegisterFileSearch()

//
// Copyright (c) XSharp B.V.  All Rights Reserved.
// Licensed under the Apache License, Version 2.0.
// See License.txt in the project root for license information.
//

USING System.Collections.Generic
USING System.IO
USING System.Linq

PUBLIC DELEGATE FileSearcher(cIn AS STRING) AS STRING
INTERNAL STATIC CLASS XSharp.FileSearch
    STATIC PRIVATE foundEntries	:= List<OBJECT>{} AS List<OBJECT>
    STATIC PRIVATE enumerator   := NULL AS IEnumerator<OBJECT>
    STATIC PRIVATE currentItem	:= NULL AS OBJECT
    STATIC PRIVATE isAtEnd		:= TRUE AS LOGIC
    STATIC Worker := FileSearchWorker AS FileSearcher

    CONST timeFormat := "HH:MM:ss" AS STRING

    INTERNAL STATIC METHOD FFCount( filespec AS STRING , attributes AS DWORD ) AS DWORD
        FindFirst(filespec,attributes)
        RETURN (DWORD)foundEntries:Count

    INTERNAL STATIC METHOD FindFirst( filespec AS STRING , attributes AS DWORD ) AS LOGIC
        LOCAL lRet := FALSE AS LOGIC

        TRY

            XSharp.IO.File.clearErrorState()

            // Split filespec in path and mask
            // when path is empty then path is current directory
            // make sure that we only search in the given path
            LOCAL cPath AS STRING
            LOCAL cMask AS STRING
            cPath := Path.GetDirectoryName(filespec)
            cMask := Path.GetFilename(filespec)
            IF String.IsNullOrEmpty(cPath)
                cPath := System.Environment.CurrentDirectory
            ENDIF
            foundEntries:Clear()
            IF attributes == FA_VOLUME
                LOCAL allDrives := DriveInfo.GetDrives() AS DriveInfo[]
                FOREACH drive AS DriveInfo IN allDrives
                    foundEntries:Add(drive)
                NEXT
            ELSE
                LOCAL oDirInfo AS DirectoryInfo
                oDirInfo := DirectoryInfo{cPath}

                LOCAL files := oDirInfo:GetFiles(cMask) AS FileInfo[]
                //VAR selectedFiles := FROM FileInfo IN files WHERE ( FileInfo:Attributes & (FileAttributes) (attributes + FA_NORMAL)) != 0 SELECT FileInfo
                FOREACH file AS FileInfo IN files
                    foundEntries:Add(file)
                NEXT

                IF (attributes & FA_DIRECTORY) == FA_DIRECTORY
                    LOCAL directories := oDirInfo:GetDirectories(cMask) AS FileSystemInfo[]
                    VAR selectedDirs := FROM DirectoryInfo IN directories WHERE (DirectoryInfo:Attributes & (FileAttributes) (attributes + FA_NORMAL) ) != 0 SELECT DirectoryInfo
                    FOREACH directory AS DirectoryInfo IN selectedDirs
                        foundEntries:Add(directory)
                    NEXT
                ENDIF
            ENDIF
            enumerator := foundEntries:GetEnumerator()
            enumerator:Reset()
            isAtEnd := !enumerator:MoveNext()
            IF  !isAtEnd
                currentItem := enumerator:Current
            ENDIF
            lRet := foundEntries:Count > 0

        CATCH oEx AS Exception

            XSharp.IO.File.setErrorState(oEx)
            lRet := FALSE

        END TRY

    RETURN lRet

    INTERNAL STATIC METHOD FindNext() AS LOGIC
        IF !isAtEnd
            isAtEnd := !enumerator:MoveNext()
            IF !isAtEnd
                currentItem := enumerator:Current
            ENDIF
        ENDIF
        RETURN !isAtEnd

    INTERNAL STATIC METHOD FName() AS STRING
        LOCAL name := "" AS STRING
        IF !isAtEnd
            IF (currentItem IS DriveInfo)
                name := ((DriveInfo)currentItem):Name
            ELSEIF (currentItem IS FileInfo)
                name := ((FileInfo)currentItem):Name
            ELSEIF (currentItem IS DirectoryInfo)
                name := ((DirectoryInfo) currentItem):Name
            ENDIF
        ENDIF
        RETURN name

    INTERNAL STATIC METHOD FSize() AS DWORD
        LOCAL size := 0 AS INT
        IF !isAtEnd
            IF currentItem IS DriveInfo
                IF ((DriveInfo) currentItem):IsReady
                    size := (INT)((DriveInfo) currentItem):TotalSize
                ENDIF
            ELSEIF (currentItem IS FileInfo)
                size := (INT)((FileInfo)currentItem):Length
            ELSEIF currentItem IS DirectoryInfo
                size := (INT)((DirectoryInfo) currentItem):GetFileSystemInfos().LongLength
            ENDIF
        ENDIF
        RETURN (DWORD) size

    INTERNAL STATIC METHOD FTime() AS STRING
        LOCAL time := "00:00:00" AS STRING
        IF !isAtEnd
            IF (currentItem IS FileInfo)
                time := ((FileInfo)currentItem):LastWriteTime.ToString(timeFormat)
            ELSEIF currentItem IS DirectoryInfo
                time := ((DirectoryInfo) currentItem):LastWriteTime.ToString(timeFormat)
            ENDIF
        ENDIF
        RETURN  time

    INTERNAL STATIC METHOD FDate() AS DateTime
        LOCAL time := DateTime.MinValue AS DateTime
        IF !isAtEnd
            IF (currentItem IS FileInfo)
                time := ((FileInfo)currentItem):LastWriteTime
            ELSEIF currentItem IS DirectoryInfo
                time := ((DirectoryInfo) currentItem):LastWriteTime
            ENDIF
        ENDIF
        RETURN  time

    INTERNAL STATIC METHOD FAttrib() AS DWORD
        LOCAL attributes := 0x00000008 AS INT
        IF !isAtEnd
            IF (currentItem IS FileInfo)
                attributes := (INT)((FileInfo)currentItem):Attributes
            ELSEIF currentItem IS DirectoryInfo
                attributes := (INT)((DirectoryInfo) currentItem):Attributes
            ENDIF
        ENDIF
        RETURN  (DWORD)attributes

        END CLASS
/// <summary>
/// Return the number of files that match a given file specification and attribute.
/// </summary>
/// <param name="cFile"></param>
/// <param name="nAttr"></param>
/// <returns>The number of files that match a given file specification and attribute.
/// </returns>
FUNCTION FFCount(cFile AS STRING,nAttr AS DWORD) AS DWORD
    RETURN XSharp.FileSearch.FFCount(cFile,nAttr)

    /// <summary>
    /// Find the first file that matches a given file specification or attribute.
    /// </summary>
    /// <param name="cFile"></param>
    /// <param name="nAttr"></param>
    /// <returns>The first file that matches a given file specification or attribute.
    /// </returns>
FUNCTION FFirst(cFile AS STRING,nAttr AS DWORD) AS LOGIC
    RETURN XSharp.FileSearch.FindFirst(cFile,nAttr)
    /// <summary>
    /// Determine the attributes of the file found after FFCount(), FFirst(), or FNext().
    /// </summary>
    /// <returns>The attributes of the file found after FFCount(), FFirst(), or FNext().
    /// </returns>
FUNCTION FAttrib() AS DWORD
    RETURN XSharp.FileSearch.FAttrib()

    /// <summary>
    /// Return the Date stamp of the file found by FFCount(), FFirst(), or FNext().
    /// </summary>
    /// <returns>The Date stamp of the file found by FFCount(), FFirst(), or FNext().
    /// </returns>
FUNCTION FDate() AS DateTime
    RETURN XSharp.FileSearch.FDate()

    /// <summary>
    /// Return the name of the file found by FFCount(), FFirst(), or FNext().
    /// </summary>
    /// <returns>
    /// </returns>
FUNCTION FName() AS STRING
    RETURN XSharp.FileSearch.FName()

    /// <summary>
    /// Find the next file that matches the file previously found by FFirst().
    /// </summary>
    /// <returns>TRUE when a next file is found. Otherwise FALSE.
    /// </returns>
FUNCTION FNext() AS LOGIC
    RETURN XSharp.FileSearch.FindNext()

    /// <summary>
    /// Return the size of the file found by FFCount(), FFirst(), or FNext().
    /// </summary>
    /// <returns>The size of the file found by FFCount(), FFirst(), or FNext().
    /// </returns>
FUNCTION FSize() AS DWORD
    RETURN XSharp.FileSearch.FSize()
    /// <summary>
    /// Return the time stamp of the file found by FFCount(), FFirst(), or FNext().
    /// </summary>
    /// <returns>The time stamp of the file found by FFCount(), FFirst(), or FNext().
    /// </returns>
FUNCTION FTime() AS STRING
    RETURN XSharp.FileSearch.FTime()

// Worker function with normal file search worker
INTERNAL FUNCTION FileSearchWorker(cFile AS STRING) AS STRING
    LOCAL lFirst AS LOGIC
    IF System.IO.File.Exists(cFile)
        RETURN Path.GetFullPath( cFile )
    ENDIF
    LOCAL aPaths AS STRING[]
    aPaths := __GetSearchPaths()
    lFirst := TRUE
    FOREACH cPath AS STRING IN aPaths
        VAR cTemp := System.IO.Path.Combine(cPath, cFile)
        IF lFirst
            // store the first path that we looked in even when the file is not found
            // to be compatible with VO
            XSharp.IO.File.LastFound := cTemp
            lFirst := FALSE
        ENDIF
        IF System.IO.File.Exists(cTemp)
            XSharp.IO.File.LastFound := cTemp
            RETURN cTemp
        ENDIF
    NEXT
    RETURN ""

    /// <summary>
    /// Register Worker function for File Search API.
    /// </summary>
    /// <param name="newWorker">Function that implements the worker. Must take STRING parameter and return a STRING</param>
    /// <returns>
    /// current Worker function
    /// </returns>
FUNCTION RegisterFileSearch(newWorker AS FileSearcher) AS FileSearcher
    LOCAL oldWorker AS FileSearcher
    oldWorker := XSharp.FileSearch.Worker
    IF newWorker != NULL
        XSharp.FileSearch.Worker := newWorker
    ENDIF
    RETURN oldWorker

    /// <summary>
    /// Determine if any file matches a given file specification.
    /// </summary>
    /// <param name="cFile">The name oif the file</param>
    /// <returns>
    /// True if the file exists, otherwise false
    /// </returns>
FUNCTION File(cFile AS STRING) AS LOGIC
    LOCAL lHasWildCards AS LOGIC
    LOCAL aPaths AS STRING[]
    LOCAL lFirst AS LOGIC
    cFile := cFile?:Trim()
    IF String.IsNullOrEmpty(cFile)
        RETURN FALSE
    ENDIF
    lHasWildCards := cFile:IndexOfAny( <CHAR>{ '*', '?' } ) > 0
    XSharp.IO.File.LastFound := ""
    IF ! lHasWildCards
        VAR cFound := XSharp.FileSearch.Worker(cFile)
        IF ! String.IsNullOrEmpty(cFound)
            XSharp.IO.File.LastFound := cFound
            RETURN TRUE
        ENDIF
    ELSE
        // wildcard, so use Directory.GetFiles()
        LOCAL files     AS STRING[]

        IF Path.IsPathRooted(cFile)
            files := Directory.GetFiles( Path.GetDirectoryName( cFile ), Path.GetFileName( cFile ) )
            IF files:Length > 0
                XSharp.IO.File.LastFound := files[1]
                RETURN TRUE
            ELSE
                // store the first path that we looked in even when the file is not found
                // to be compatible with VO
                XSharp.IO.File.LastFound := cFile
                RETURN FALSE
            ENDIF
        ELSE
            // Look in current directory first and if that fails through the whole normal search list
            IF __FileHelper(Environment.CurrentDirectory, cFile, FALSE )
                RETURN TRUE
            ENDIF
            aPaths := __GetSearchPaths()
            lFirst := TRUE
            FOREACH cPath AS STRING IN aPaths
                IF __FileHelper(cPath, cFile, lFirst )
                    RETURN TRUE
                ENDIF
                lFirst := FALSE
            NEXT
        ENDIF
    ENDIF
    RETURN FALSE
    /// <summary>
    /// Return the name and path of the file that was used by FXOpen() or File().
    /// </summary>
    /// <returns>
    /// </returns>
FUNCTION FPathName() AS STRING

    RETURN XSharp.IO.File.LastFound

INTERNAL FUNCTION __FileHelper(cPath AS STRING, cFileSpec AS STRING, lSavePath AS LOGIC) AS LOGIC
    LOCAL cTemp AS STRING
    LOCAL cFile AS STRING
    LOCAL files AS STRING[]
    IF ! System.IO.Directory.Exists(cPath)
        RETURN FALSE
    ENDIF
    cTemp := System.IO.Path.Combine(cPath, cFileSpec)
    cPath := System.IO.Path.GetDirectoryName(cTemp)
    cFile := System.IO.Path.GetFileName(cTemp)
    IF ! System.IO.Directory.Exists(cPath)
        RETURN FALSE
    ENDIF
    files := System.IO.Directory.GetFiles(cPath, cFile)
    IF files:Length > 0
        XSharp.IO.File.LastFound := files[0]
    ELSEIF lSavePath
        XSharp.IO.File.LastFound := cTemp
    ENDIF
    RETURN files:Length > 0

INTERNAL FUNCTION __GetSearchPaths() AS STRING[]
// Not found, now use the path settings from SetDefault and SetPath()
// if SetPath() is empty then we look through the Environment variable Path
LOCAL aDefault AS STRING[]
aDefault := SetPathArray()
IF aDefault != NULL
    RETURN aDefault
ENDIF

VAR aPaths := List<STRING>{}
VAR cPath  := SetDefault()
IF !String.IsNullOrEmpty(cPath)
    aPaths:Add(cPath)
ENDIF
cPath := SetPath()
IF String.IsNullOrEmpty(cPath)
    cPath := GetEnv("PATH")
ENDIF
IF !String.IsNullOrEmpty(cPath)
    VAR aElements := cPath:Split(<CHAR>{ ';' }, StringSplitOptions.RemoveEmptyEntries )
    aPaths:AddRange(aElements)
ENDIF
aDefault := aPaths:ToArray()
SetPathArray(aDefault)
RETURN aDefault

//
// Copyright (c) XSharp B.V.  All Rights Reserved.
// Licensed under the Apache License, Version 2.0.
// See License.txt in the project root for license information.
//

USING System.Collections.Generic
USING System.IO
USING System.Linq

INTERNAL STATIC CLASS XSharp.FileSearch
    STATIC PRIVATE foundEntries	:= List<OBJECT>{} AS List<OBJECT>
    STATIC PRIVATE enumerator   := NULL AS IEnumerator<OBJECT>
    STATIC PRIVATE currentItem	:= NULL AS OBJECT
    STATIC PRIVATE isAtEnd		:= TRUE AS LOGIC
    CONST timeFormat := "HH:MM:ss" AS STRING

    INTERNAL STATIC METHOD FFCount( filespec AS STRING , attributes AS DWORD ) AS DWORD
        FindFirst(filespec,attributes)
        RETURN (DWORD)foundEntries:Count

    INTERNAL STATIC METHOD FindFirst( filespec AS STRING , attributes AS DWORD ) AS LOGIC
        LOCAL lRet := FALSE AS LOGIC

        TRY

            XSharp.IO.File.clearErrorState()

            // Split filespec in path and mask
            // when path is empty then path is current directory
            // make sure that we only search in the given path
            LOCAL cPath AS STRING
            LOCAL cMask AS STRING
            cPath := Path.GetDirectoryName(filespec)
            cMask := Path.GetFilename(filespec)
            IF String.IsNullOrEmpty(cPath)
                cPath := System.Environment.CurrentDirectory
            ENDIF
            foundEntries:Clear()
            IF attributes == FA_VOLUME
                LOCAL allDrives := DriveInfo.GetDrives() AS DriveInfo[]
                FOREACH drive AS DriveInfo IN allDrives
                    foundEntries:Add(drive)
                NEXT
            ELSE
                LOCAL oDirInfo AS DirectoryInfo
                oDirInfo := DirectoryInfo{cPath}

                LOCAL files := oDirInfo:GetFiles(cMask) AS FileInfo[]
                //VAR selectedFiles := FROM FileInfo IN files WHERE ( FileInfo:Attributes & (FileAttributes) (attributes + FA_NORMAL)) != 0 SELECT FileInfo
                FOREACH file AS FileInfo IN files
                    foundEntries:Add(file)
                NEXT

                IF (attributes & FA_DIRECTORY) == FA_DIRECTORY
                    LOCAL directories := oDirInfo:GetDirectories(cMask) AS FileSystemInfo[]
                    VAR selectedDirs := FROM DirectoryInfo IN directories WHERE (DirectoryInfo:Attributes & (FileAttributes) (attributes + FA_NORMAL) ) != 0 SELECT DirectoryInfo
                    FOREACH directory AS DirectoryInfo IN selectedDirs
                        foundEntries:Add(directory)
                    NEXT
                ENDIF
            ENDIF
            enumerator := foundEntries:GetEnumerator()
            enumerator:Reset()
            isAtEnd := !enumerator:MoveNext()
            IF  !isAtEnd
                currentItem := enumerator:Current
            ENDIF
            lRet := foundEntries:Count > 0

        CATCH oEx AS Exception

            XSharp.IO.File.setErrorState(oEx)
            lRet := FALSE

        END TRY

    RETURN lRet

    INTERNAL STATIC METHOD FindNext() AS LOGIC
        IF !isAtEnd
            isAtEnd := !enumerator:MoveNext()
            IF !isAtEnd
                currentItem := enumerator:Current
            ENDIF
        ENDIF
        RETURN !isAtEnd

    INTERNAL STATIC METHOD FName() AS STRING
        LOCAL name := "" AS STRING
        IF !isAtEnd
            IF (currentItem IS DriveInfo)
                name := ((DriveInfo)currentItem):Name
            ELSEIF (currentItem IS FileInfo)
                name := ((FileInfo)currentItem):Name
            ELSEIF (currentItem IS DirectoryInfo)
                name := ((DirectoryInfo) currentItem):Name
            ENDIF
        ENDIF
        RETURN name

    INTERNAL STATIC METHOD FSize() AS DWORD
        LOCAL size := 0 AS INT
        IF !isAtEnd
            IF currentItem IS DriveInfo
                IF ((DriveInfo) currentItem):IsReady
                    size := (INT)((DriveInfo) currentItem):TotalSize
                ENDIF
            ELSEIF (currentItem IS FileInfo)
                size := (INT)((FileInfo)currentItem):Length
            ELSEIF currentItem IS DirectoryInfo
                size := (INT)((DirectoryInfo) currentItem):GetFileSystemInfos().LongLength
            ENDIF
        ENDIF
        RETURN (DWORD) size

    INTERNAL STATIC METHOD FTime() AS STRING
        LOCAL time := "00:00:00" AS STRING
        IF !isAtEnd
            IF (currentItem IS FileInfo)
                time := ((FileInfo)currentItem):LastWriteTime.ToString(timeFormat)
            ELSEIF currentItem IS DirectoryInfo
                time := ((DirectoryInfo) currentItem):LastWriteTime.ToString(timeFormat)
            ENDIF
        ENDIF
        RETURN  time

    INTERNAL STATIC METHOD FDate() AS DateTime
        LOCAL time := DateTime.MinValue AS DateTime
        IF !isAtEnd
            IF (currentItem IS FileInfo)
                time := ((FileInfo)currentItem):LastWriteTime
            ELSEIF currentItem IS DirectoryInfo
                time := ((DirectoryInfo) currentItem):LastWriteTime
            ENDIF
        ENDIF
        RETURN  time

    INTERNAL STATIC METHOD FAttrib() AS DWORD
        LOCAL attributes := 0x00000008 AS INT
        IF !isAtEnd
            IF (currentItem IS FileInfo)
                attributes := (INT)((FileInfo)currentItem):Attributes
            ELSEIF currentItem IS DirectoryInfo
                attributes := (INT)((DirectoryInfo) currentItem):Attributes
            ENDIF
        ENDIF
        RETURN  (DWORD)attributes

        END CLASS
/// <summary>
/// Return the number of files that match a given file specification and attribute.
/// </summary>
/// <param name="cFile"></param>
/// <param name="nAttr"></param>
/// <returns>The number of files that match a given file specification and attribute.
/// </returns>
FUNCTION FFCount(cFile AS STRING,nAttr AS DWORD) AS DWORD
    RETURN XSharp.FileSearch.FFCount(cFile,nAttr)

    /// <summary>
    /// Find the first file that matches a given file specification or attribute.
    /// </summary>
    /// <param name="cFile"></param>
    /// <param name="nAttr"></param>
    /// <returns>The first file that matches a given file specification or attribute.
    /// </returns>
FUNCTION FFirst(cFile AS STRING,nAttr AS DWORD) AS LOGIC
    RETURN XSharp.FileSearch.FindFirst(cFile,nAttr)
    /// <summary>
    /// Determine the attributes of the file found after FFCount(), FFirst(), or FNext().
    /// </summary>
    /// <returns>The attributes of the file found after FFCount(), FFirst(), or FNext().
    /// </returns>
FUNCTION FAttrib() AS DWORD
    RETURN XSharp.FileSearch.FAttrib()

    /// <summary>
    /// Return the Date stamp of the file found by FFCount(), FFirst(), or FNext().
    /// </summary>
    /// <returns>The Date stamp of the file found by FFCount(), FFirst(), or FNext().
    /// </returns>
FUNCTION FDate() AS DateTime
    RETURN XSharp.FileSearch.FDate()

    /// <summary>
    /// Return the name of the file found by FFCount(), FFirst(), or FNext().
    /// </summary>
    /// <returns>
    /// </returns>
FUNCTION FName() AS STRING
    RETURN XSharp.FileSearch.FName()

    /// <summary>
    /// Find the next file that matches the file previously found by FFirst().
    /// </summary>
    /// <returns>TRUE when a next file is found. Otherwise FALSE.
    /// </returns>
FUNCTION FNext() AS LOGIC
    RETURN XSharp.FileSearch.FindNext()

    /// <summary>
    /// Return the size of the file found by FFCount(), FFirst(), or FNext().
    /// </summary>
    /// <returns>The size of the file found by FFCount(), FFirst(), or FNext().
    /// </returns>
FUNCTION FSize() AS DWORD
    RETURN XSharp.FileSearch.FSize()
    /// <summary>
    /// Return the time stamp of the file found by FFCount(), FFirst(), or FNext().
    /// </summary>
    /// <returns>The time stamp of the file found by FFCount(), FFirst(), or FNext().
    /// </returns>
FUNCTION FTime() AS STRING
    RETURN XSharp.FileSearch.FTime()

    /// <summary>
    /// Determine if any file matches a given file specification.
    /// </summary>
    /// <param name="cFile">The name oif the file</param>
    /// <returns>
    /// True if the file exists, otherwise false
    /// </returns>
FUNCTION File(cFile AS STRING) AS LOGIC
    LOCAL lFound AS LOGIC
    LOCAL lHasWildCards AS LOGIC
    LOCAL aPaths AS STRING[]
    LOCAL cTemp AS STRING
    LOCAL lFirst AS LOGIC
    IF String.IsNullOrEmpty(cFile)
        RETURN FALSE
    ENDIF
    lHasWildCards := cFile:IndexOfAny( <CHAR>{ '*', '?' } ) > 0
    XSharp.IO.File.LastFound := ""
    IF ! lHasWildCards
        lFound := System.IO.File.Exists(cFile)
        IF lFound
            XSharp.IO.File.LastFound := Path.GetFullPath( cFile )
            RETURN TRUE
        ENDIF
        aPaths := __GetSearchPaths()
        lFirst := TRUE
        FOREACH cPath AS STRING IN aPaths
            cTemp := System.IO.Path.Combine(cPath, cFile)
            IF lFirst
                // store the first path that we looked in even when the file is not found
                // to be compatible with VO
                XSharp.IO.File.LastFound := cTemp
                lFirst := FALSE
            ENDIF
            lFound := System.IO.File.Exists(cTemp)
            IF lFound
                XSharp.IO.File.LastFound := cTemp
                RETURN TRUE
            ENDIF
        NEXT
    ELSE
        // wildcard, so use Directory.GetFiles()
        LOCAL files     AS STRING[]

        IF Path.IsPathRooted(cFile)
            files := Directory.GetFiles( Path.GetDirectoryName( cFile ), Path.GetFileName( cFile ) )
            IF files:Length > 0
                XSharp.IO.File.LastFound := files[1]
                RETURN TRUE
            ELSE
                // store the first path that we looked in even when the file is not found
                // to be compatible with VO
                XSharp.IO.File.LastFound := cFile
                RETURN FALSE
            ENDIF
        ELSE
            // Look in current directory first and if that fails through the whole normal search list
            IF __FileHelper(Environment.CurrentDirectory, cFile, FALSE )
                RETURN TRUE
            ENDIF
            aPaths := __GetSearchPaths()
            lFirst := TRUE
            FOREACH cPath AS STRING IN aPaths
                IF __FileHelper(cPath, cFile, lFirst )
                    RETURN TRUE
                ENDIF
                lFirst := FALSE
            NEXT
        ENDIF
    ENDIF
    RETURN FALSE
    /// <summary>
    /// Return the name and path of the file that was used by FXOpen() or File().
    /// </summary>
    /// <returns>
    /// </returns>
FUNCTION FPathName() AS STRING

    RETURN XSharp.IO.File.LastFound

INTERNAL FUNCTION __FileHelper(cPath AS STRING, cFileSpec AS STRING, lSavePath AS LOGIC) AS LOGIC
    LOCAL cTemp AS STRING
    LOCAL cFile AS STRING
    LOCAL files AS STRING[]
    IF ! System.IO.Directory.Exists(cPath)
        RETURN FALSE
    ENDIF
    cTemp := System.IO.Path.Combine(cPath, cFileSpec)
    cPath := System.IO.Path.GetDirectoryName(cTemp)
    cFile := System.IO.Path.GetFileName(cTemp)
    IF ! System.IO.Directory.Exists(cPath)
        RETURN FALSE
    ENDIF
    files := System.IO.Directory.GetFiles(cPath, cFile)
    IF files:Length > 0
        XSharp.IO.File.LastFound := files[0]
    ELSEIF lSavePath
        XSharp.IO.File.LastFound := cTemp
    ENDIF
    RETURN files:Length > 0

INTERNAL FUNCTION __GetSearchPaths() AS STRING[]
// Not found, now use the path settings from SetDefault and SetPath()
// if SetPath() is empty then we look through the Environment variable Path
LOCAL aDefault AS STRING[]
aDefault := SetPathArray()
IF aDefault != NULL
    RETURN aDefault
ENDIF

VAR aPaths := List<STRING>{}
VAR cPath  := SetDefault()
IF !String.IsNullOrEmpty(cPath)
    aPaths:Add(cPath)
ENDIF
cPath := SetPath()
IF String.IsNullOrEmpty(cPath)
    cPath := GetEnv("PATH")
ENDIF
IF !String.IsNullOrEmpty(cPath)
    VAR aElements := cPath:Split(<CHAR>{ ';' }, StringSplitOptions.RemoveEmptyEntries )
    aPaths:AddRange(aElements)
ENDIF
aDefault := aPaths:ToArray()
SetPathArray(aDefault)
RETURN aDefault


make arrNL a helper with smaller scope

make arrNL a helper with smaller scope

import "../src/LangPrelude.prg" (maybeM)
import "../tests/Inventory.prg"

data NatList :: Inventory Nat ~> * where
  Nope :: NatList []i
  Augment :: NatList i -> Nat' n -> NatList [i; n]i
 deriving LeftList(nl)

data LeftThrist :: forall (l :: *1) . (l ~> l ~> *)  ~> l ~> l ~> * where
  LNil :: LeftThrist k a a
  LCons :: LeftThrist k a b -> k b c -> LeftThrist k a c
 deriving LeftList(lt)

data Elem :: Inventory Nat ~> Inventory Nat ~> * where
  Single :: NatList nl -> Elem i {merge i nl}

monad maybeM

mergeNL :: NatList i -> NatList j -> Maybe (NatList {merge i j})
mergeNL []nl j = Just j
mergeNL (i@[as; a]nl) []nl = Just i
mergeNL [as; a]nl [bs; b]nl = arrNL as bs a b a b
  where arrNL :: NatList i -> NatList j -> Nat' a' -> Nat' b' -> Nat' a -> Nat' b -> Maybe (NatList {arrange i j a' b' a b})
        arrNL i j 0v (1+b')v a b = do { iaj <- mergeNL [i; a]nl j; return [iaj; b]nl }
        arrNL i j (1+a')v 0v a b = do { ijb <- mergeNL i [j; b]nl; return [ijb; a]nl }
        arrNL i j (1+a')v (1+b')v a b = arrNL i j a' b' a b
        arrNL _ _ _ _ _ _ = Nothing
mergeNL _ _ = Nothing

join :: NatList i -> LeftThrist Elem []i i -> NatList j -> Maybe (LeftThrist Elem []i {merge i j}, NatList {merge i j})
join i thr j = do { ij <- mergeNL i j
                  ; return ([thr; Single j]lt, ij) }

Just (t1, e1) = let start = [0v, 2v, 4v]nl in join start [Single start]lt [3v]nl
Just (t2, e2) = join e1 t1 [1v, 5v]nl

-- proposition for mergability
--
prop Disjoint :: Inventory Nat ~> Inventory Nat ~> * where
  WithEmpty :: Disjoint []i i
  WithLastAndRest :: Excluded i n -> Disjoint j i -> Disjoint [j; n]i i

-- exclusivity
--
prop Excluded :: Inventory Nat ~> Nat ~> * where
  NotInEmpty :: Excluded []i n
  NoZero :: Excluded x 0t -> Excluded [x; (1+y)t]i 0t
  NoHigher :: Excluded x (1+n)t -> Excluded [x; 0t]i (1+n)t
  ReduceToLower :: Excluded x (1+n)t -> Excluded [y]i n -> Excluded [x; (1+y)t]i (1+n)t

-- the total version of mergeNL
--
mergeNL' :: Disjoint i j => NatList i -> NatList j -> NatList {merge i j}
mergeNL' i j = let Just m = mergeNL i j in m

-- creating disjointness evidence
--
tryExcluded :: NatList i -> Nat' n -> Maybe (Excluded i n)
tryExcluded []nl n = Just NotInEmpty
tryExcluded [x; (1+_)v]nl 0v = do ev <- tryExcluded x 0v
                                  return (NoZero ev)
tryExcluded [x; 0v]nl (n@(1+_)v) = do ev <- tryExcluded x n
                                      return (NoHigher ev)
tryExcluded [x; (1+y)v]nl (1+n)v = do ev1 <- tryExcluded x (1+n)v
                                      ev2 <- tryExcluded [y]nl n
                                      return (ReduceToLower ev1 ev2)
tryExcluded _ _ = Nothing

tryDisjoint :: NatList i -> NatList j -> Maybe (Disjoint i j)
tryDisjoint []nl _ = Just WithEmpty
tryDisjoint [j; n]nl i = do ev1 <- tryExcluded i n
                            ev2 <- tryDisjoint j i
                            return (WithLastAndRest ev1 ev2)
tryDisjoint _ _ = Nothing

import "../src/LangPrelude.prg" (maybeM)
import "../tests/Inventory.prg"

data NatList :: Inventory Nat ~> * where
  Nope :: NatList []i
  Augment :: NatList i -> Nat' n -> NatList [i; n]i
 deriving LeftList(nl)

data LeftThrist :: forall (l :: *1) . (l ~> l ~> *)  ~> l ~> l ~> * where
  LNil :: LeftThrist k a a
  LCons :: LeftThrist k a b -> k b c -> LeftThrist k a c
 deriving LeftList(lt)

data Elem :: Inventory Nat ~> Inventory Nat ~> * where
  Single :: NatList nl -> Elem i {merge i nl}

monad maybeM

mergeNL :: NatList i -> NatList j -> Maybe (NatList {merge i j})
mergeNL []nl j = Just j
mergeNL (i@[as; a]nl) []nl = Just i
mergeNL [as; a]nl [bs; b]nl = arrNL as bs a b a b
mergeNL _ _ = Nothing

arrNL :: NatList i -> NatList j -> Nat' a' -> Nat' b' -> Nat' a -> Nat' b -> Maybe (NatList {arrange i j a' b' a b})
arrNL i j 0v (1+b')v a b = do { iaj <- mergeNL [i; a]nl j; return [iaj; b]nl }
arrNL i j (1+a')v 0v a b = do { ijb <- mergeNL i [j; b]nl; return [ijb; a]nl }
arrNL i j (1+a')v (1+b')v a b = arrNL i j a' b' a b
arrNL _ _ _ _ _ _ = Nothing

join :: NatList i -> LeftThrist Elem []i i -> NatList j -> Maybe (LeftThrist Elem []i {merge i j}, NatList {merge i j})
join i thr j = do { ij <- mergeNL i j
                  ; return ([thr; Single j]lt, ij) }

Just (t1, e1) = let start = [0v, 2v, 4v]nl in join start [Single start]lt [3v]nl
Just (t2, e2) = join e1 t1 [1v, 5v]nl

-- proposition for mergability
--
prop Disjoint :: Inventory Nat ~> Inventory Nat ~> * where
  WithEmpty :: Disjoint []i i
  WithLastAndRest :: Excluded i n -> Disjoint j i -> Disjoint [j; n]i i

-- exclusivity
--
prop Excluded :: Inventory Nat ~> Nat ~> * where
  NotInEmpty :: Excluded []i n
  NoZero :: Excluded x 0t -> Excluded [x; (1+y)t]i 0t
  NoHigher :: Excluded x (1+n)t -> Excluded [x; 0t]i (1+n)t
  ReduceToLower :: Excluded x (1+n)t -> Excluded [y]i n -> Excluded [x; (1+y)t]i (1+n)t

-- the total version of mergeNL
--
mergeNL' :: Disjoint i j => NatList i -> NatList j -> NatList {merge i j}
mergeNL' i j = let Just m = mergeNL i j in m

-- creating disjointness evidence
--
tryExcluded :: NatList i -> Nat' n -> Maybe (Excluded i n)
tryExcluded []nl n = Just NotInEmpty
tryExcluded [x; (1+_)v]nl 0v = do ev <- tryExcluded x 0v
                                  return (NoZero ev)
tryExcluded [x; 0v]nl (n@(1+_)v) = do ev <- tryExcluded x n
                                      return (NoHigher ev)
tryExcluded [x; (1+y)v]nl (1+n)v = do ev1 <- tryExcluded x (1+n)v
                                      ev2 <- tryExcluded [y]nl n
                                      return (ReduceToLower ev1 ev2)
tryExcluded _ _ = Nothing

tryDisjoint :: NatList i -> NatList j -> Maybe (Disjoint i j)
tryDisjoint []nl _ = Just WithEmpty
tryDisjoint [j; n]nl i = do ev1 <- tryExcluded i n
                            ev2 <- tryDisjoint j i
                            return (WithLastAndRest ev1 ev2)
tryDisjoint _ _ = Nothing


flip arguments to Excluded

flip arguments to Excluded

import "../src/LangPrelude.prg" (maybeM)
import "Inventory.prg"

data NatList :: Inventory Nat ~> * where
  Nope :: NatList []i
  Augment :: NatList i -> Nat' n -> NatList [i; n]i
 deriving LeftList(nl)

data LeftThrist :: forall (l :: *1) . (l ~> l ~> *)  ~> l ~> l ~> * where
  LNil :: LeftThrist k a a
  LCons :: LeftThrist k a b -> k b c -> LeftThrist k a c
 deriving LeftList(lt)

data Elem :: Inventory Nat ~> Inventory Nat ~> * where
  Single :: NatList nl -> Elem i {merge i nl}

monad maybeM

mergeNL :: NatList i -> NatList j -> Maybe (NatList {merge i j})
mergeNL []nl j = Just j
mergeNL (i@[as; a]nl) []nl = Just i
mergeNL [as; a]nl [bs; b]nl = arrNL as bs a b a b
mergeNL _ _ = Nothing

arrNL :: NatList i -> NatList j -> Nat' a' -> Nat' b' -> Nat' a -> Nat' b -> Maybe (NatList {arrange i j a' b' a b})
arrNL i j 0v (1+b')v a b = do { iaj <- mergeNL [i; a]nl j; return [iaj; b]nl }
arrNL i j (1+a')v 0v a b = do { ijb <- mergeNL i [j; b]nl; return [ijb; a]nl }
arrNL i j (1+a')v (1+b')v a b = arrNL i j a' b' a b
arrNL _ _ _ _ _ _ = Nothing

join :: NatList i -> LeftThrist Elem []i i -> NatList j -> Maybe (LeftThrist Elem []i {merge i j}, NatList {merge i j})
join i thr j = do { ij <- mergeNL i j
                  ; return ([thr; Single j]lt, ij) }

Just (t1, e1) = let start = [0v, 2v, 4v]nl in join start [Single start]lt [3v]nl
Just (t2, e2) = join e1 t1 [1v, 5v]nl

-- proposition for mergability
--
prop Disjoint :: Inventory Nat ~> Inventory Nat ~> * where
  WithEmpty :: Disjoint []i i
  WithLastAndRest :: Excluded i n -> Disjoint j i -> Disjoint [j; n]i i

-- exclusivity
--
prop Excluded :: Inventory Nat ~> Nat ~> * where
  NotInEmpty :: Excluded []i n
  NoZero :: Excluded x 0t -> Excluded [x; (1+y)t]i 0t
  NoHigher :: Excluded x (1+n)t -> Excluded [x; 0t]i (1+n)t
  ReduceToLower :: Excluded x (1+n)t -> Excluded [y]i n -> Excluded [x; (1+y)t]i (1+n)t

-- the total version of mergeNL
--
mergeNL' :: Disjoint i j => NatList i -> NatList j -> NatList {merge i j}
mergeNL' i j = let Just m = mergeNL i j in m

-- creating disjointness evidence
--
tryExcluded :: NatList i -> Nat' n -> Maybe (Excluded i n)
tryExcluded []nl n = Just NotInEmpty
tryExcluded [x; (1+_)v]nl 0v = do ev <- tryExcluded x 0v
                                  return (NoZero ev)
tryExcluded [x; 0v]nl (n@(1+_)v) = do ev <- tryExcluded x n
                                      return (NoHigher ev)
tryExcluded [x; (1+y)v]nl (1+n)v = do ev1 <- tryExcluded x (1+n)v
                                      ev2 <- tryExcluded [y]nl n
                                      return (ReduceToLower ev1 ev2)
tryExcluded _ _ = Nothing

tryDisjoint :: NatList i -> NatList j -> Maybe (Disjoint i j)
tryDisjoint []nl _ = Just WithEmpty
tryDisjoint [j; n]nl i = do ev1 <- tryExcluded i n
                            ev2 <- tryDisjoint j i
                            return (WithLastAndRest ev1 ev2)
tryDisjoint _ _ = Nothing

import "../src/LangPrelude.prg" (maybeM)
import "Inventory.prg"

data NatList :: Inventory Nat ~> * where
  Nope :: NatList []i
  Augment :: NatList i -> Nat' n -> NatList [i; n]i
 deriving LeftList(nl)

data LeftThrist :: forall (l :: *1) . (l ~> l ~> *)  ~> l ~> l ~> * where
  LNil :: LeftThrist k a a
  LCons :: LeftThrist k a b -> k b c -> LeftThrist k a c
 deriving LeftList(lt)

data Elem :: Inventory Nat ~> Inventory Nat ~> * where
  Single :: NatList nl -> Elem i {merge i nl}

monad maybeM

mergeNL :: NatList i -> NatList j -> Maybe (NatList {merge i j})
mergeNL []nl j = Just j
mergeNL (i@[as; a]nl) []nl = Just i
mergeNL [as; a]nl [bs; b]nl = arrNL as bs a b a b
mergeNL _ _ = Nothing

arrNL :: NatList i -> NatList j -> Nat' a' -> Nat' b' -> Nat' a -> Nat' b -> Maybe (NatList {arrange i j a' b' a b})
arrNL i j 0v (1+b')v a b = do { iaj <- mergeNL [i; a]nl j; return [iaj; b]nl }
arrNL i j (1+a')v 0v a b = do { ijb <- mergeNL i [j; b]nl; return [ijb; a]nl }
arrNL i j (1+a')v (1+b')v a b = arrNL i j a' b' a b
arrNL _ _ _ _ _ _ = Nothing

join :: NatList i -> LeftThrist Elem []i i -> NatList j -> Maybe (LeftThrist Elem []i {merge i j}, NatList {merge i j})
join i thr j = do { ij <- mergeNL i j
                  ; return ([thr; Single j]lt, ij) }

Just (t1, e1) = let start = [0v, 2v, 4v]nl in join start [Single start]lt [3v]nl
Just (t2, e2) = join e1 t1 [1v, 5v]nl

-- proposition for mergability
--
prop Disjoint :: Inventory Nat ~> Inventory Nat ~> * where
  WithEmpty :: Disjoint []i i
  WithLastAndRest :: Excluded n i -> Disjoint j i -> Disjoint [j; n]i i

-- exclusivity
--
prop Excluded :: Nat ~> Inventory Nat ~> * where
  NotInEmpty :: Excluded n []i
  NoZero :: Excluded 0t x -> Excluded 0t [x; (1+y)t]i
  NoHigher :: Excluded (1+n)t x -> Excluded (1+n)t [x; 0t]i
  ReduceToLower :: Excluded (1+n)t x -> Excluded n [y]i -> Excluded (1+n)t [x; (1+y)t]i

-- the total version of mergeNL
--
mergeNL' :: Disjoint i j => NatList i -> NatList j -> NatList {merge i j}
mergeNL' i j = let Just m = mergeNL i j in m

-- creating disjointness evidence
--
tryExcluded :: Nat' n -> NatList i -> Maybe (Excluded n i)
tryExcluded n []nl = Just NotInEmpty
tryExcluded 0v [x; (1+_)v]nl = do ev <- tryExcluded 0v x
                                  return (NoZero ev)
tryExcluded (n@(1+_)v) [x; 0v]nl = do ev <- tryExcluded n x
                                      return (NoHigher ev)
tryExcluded (1+n)v [x; (1+y)v]nl = do ev1 <- tryExcluded (1+n)v x
                                      ev2 <- tryExcluded  n [y]nl
                                      return (ReduceToLower ev1 ev2)
tryExcluded _ _ = Nothing

tryDisjoint :: NatList i -> NatList j -> Maybe (Disjoint i j)
tryDisjoint []nl _ = Just WithEmpty
tryDisjoint [j; n]nl i = do ev1 <- tryExcluded n i
                            ev2 <- tryDisjoint j i
                            return (WithLastAndRest ev1 ev2)
tryDisjoint _ _ = Nothing


simplify

simplify

-- Modeling Opetopes
-- here is Eric's editor: http://sma.epfl.ch/~finster/opetope/opetope.html
--
-- Note: Kock et al. use a similar scheme, where
--          - dots    <-->   lines
--          - spheres <-->   dots
--          - lines disappear
--          -                spheres appear

-- Note: In Eric's new work (at IAS) there are no
--       dots any more, instead he uses 'external cards', so
--          - (external) cards   <-->  lines
--          - space between stacked cards <--> external cards
--          - lines disappear
--          -                (regular) cards appear

import "../tests/Nat.prg"

-- GLOBAL TODOs
----------------

-- Naming: Seems essential for identifying things Hor(Name), Ver(Tree)
--         Name can be Label, then Niches (= sequences of opetope names).
--         the latter arise from the composition rule.
--         Note: don't store names in Stacks, that kills alpha
--               conversion. Instead names should be pushed into nodes
--               'singleton style' from outside: (node :: Tree (Hor `g))

-- Morphisms: given an opetope and a pointer to one of its cards
--            extract the opetope of that face (do we need a label
--            space to reliably find it?). This must be a type
--            function, with an algorithm accompanying it to extract
--            the face proper.

-- Composition: grafting of trees to external cards, but only if the
--              morphisms (faces) match. lower-dim stuff is unaffected.

-- Swapping: given a proof of equality between two niches, provide an
--           operation to swap them, replacing old faces by new ones,
--           FGL-style (functional graph library), just note that
--           certain morphisms are gone, others appeared.

-- References: a disciplined way of saying "I am an identical node to that guy",
--             by corollary these always obtain the same names.
--             a topologist would say 'surgery' (http://en.wikipedia.org/wiki/Surgery_theory)
--             We get a new Tree flavour, Ref, at least one up, followed by
--             naturals to index a node in a subtree.
--             At this point we are doing algebraic topology, and dealing with
--             closed manifolds, so that we can do homology etc. on them.
--             In logic this corresponds to relations, satisfiability.

-- Quoting: So far we have only dealt with data, i.e. quoted (inert) syntax.
--          we need a way to convert this syntax to code (e.g. at some stage),
--          to obtain semantics. We can have the usual splicing game.
--          Lisp does this with sexprs and macros.
--          The code needs then be executed (run, decreasing stage), when
--          it becomes active, and we can observe the manifestation of its
--          semantics. The reduction system could go along the lines of the
--          (typed) LambdaGraph.

-- NbE: I fully believe we can use this technique to reduce opetopic terms
--      to normal form. ('many syntax', 'one semantics' adjunction:
--                       http://www.logicmatters.net/resources/pdfs/Galois.pdf)

-- TODO: these three must be LeftLists
--
kind Trees = NoTree | Pre (Tree d) Trees deriving syntax (ts) List(NoTree, Pre)

data ZoomCompley :: Tree e ~> Tree f ~> * where
  Nily :: ZoomCompley a a
  Consy :: Stack a b -> ZoomCompley b c -> ZoomCompley a c
 deriving List(cply)

data ZoomComplex :: Trees ~> * where
  Nilx :: ZoomComplex [()tr]ts
  Endx :: Stack a b -> ZoomComplex [a, b]ts
  Consx :: Stack a b -> ZoomComplex [b; c]ts -> ZoomComplex [a, b; c]ts
 deriving syntax (cplx) List(Nilx, Consx) Item(Endx)

data Dir :: *2 where
  Hor :: Dir
  Ver :: Dir

-- define the Tree kind, a rose tree
-- note: we may need a two-level kind, since we need to track disjointness
--       of subtrees
-- todo: later we may want to have a label kind parameter too

data Tree :: Dir ~> *1 where
  Unit :: Tree Ver
  Ni :: Tree Hor
  Fork :: Tree d ~> Tree Hor ~> Tree Hor
 deriving syntax (tr) List(Ni, Fork) Unit(Unit)

-- make it singleton

data Tree' :: Tree d ~> * where
  In :: Tree' ()tr
  Fork :: treelike head -> Tree' tail -> Tree' [head; tail]tr
  Done :: Tree' []tr
 deriving syntax (ar) List(Done, Fork) Unit(In) -- "arbre"
-- http://www.papoulipoesique.com/wp-content/uploads/2013/06/arbre.jpg

-- define a proposition for subtrees
-- to be checked: TakeHead must ensure that all the node is consumed

prop Subtree :: Tree d ~> Tree e ~> * where
  UnitSub :: Subtree ()tr tr
  BothNil :: Subtree []tr []tr
  TakeHead :: Subtree head head' -> Subtree tail tail' -> Subtree [head; tail]tr [head'; tail']tr

-- TODO: separate the notions of Niche / Frame / Cell
kind Volume = FramedHollow | FilledCell
kind Diagram = Closed Volume | OpenNiche
-- should be a parameter to Stack

-- now we can stack cards (these are zooms in Kock et al. parlance)

data Stack :: Tree d ~> Tree e ~> * where
  Corolla :: Corolla tr => Tree' tr -> Stack tr ()tr

  -- TODO: needed?
  --Expand :: (Subtree consumed tr, {nodeValence consumed} `Equal` {nodeValence tr}) => Stack consumed prod -> Stack tr prod

  -- add another target face to a web
  Target :: ({nodes tr} `Equal` {nodeValence out}) => Stack tr out -> Stack tr out

  -- the following three grab a node (and possibly its offsprings) and incorporate it into a single card
  NodeDone :: Stack []tr [()tr]tr
  Pick :: {- EntireNode => -} Stack head prodhead -> Stack tail prodtail -> Stack [head; tail]tr [prodhead; prodtail]tr
  Exclude :: {- EntireNode => -} Stack tail prod -> Stack [()tr; tail]tr prod
  -- TODO: maybe just specify a subtree (Tree') and that's it

  On :: (Subtree tr' tr, Pointers 1t at out) => Stack tr' out' -> Stack tr out -> Tree' at -> Stack tr {graft out' at out}

  -- building niches (pasting diagrams)
  -- TODO: these must produce a composite labelled Hor
  NicheDone :: Stack ()tr []tr
  Niche :: Stack tr out -> Stack tr [out]tr
  Also :: Pointers 1t at tr
       => Tree' at -> Stack tr' out' -> Stack tr out -> Stack {extgraft tr' at tr} [out'; out]tr

  -- put a frame around a niche
  Frame :: (Corolla out, {nodes tr}  `Equal` {nodeValence out}) => Stack tr out -> Stack tr out

 deriving syntax(z) Record(NicheDone, Also) Item(Target)

stop = ({}z)z

-- this is bogus, just make it compile again...
up :: Reference tr => Stack ()tr tr -> Stack ()tr [tr]tr
up inner = ({()ar=inner}z)z

-- it remains to define corollas

-- TODO: one could say {nodes tr} == 1
prop Corolla :: Tree d ~> * where
  None' :: Corolla []tr
  One' :: Corolla tail -> Corolla [()tr; tail]tr

--  o   --->  |
--  |         |

lolliCell :: Stack []tr ()tr
lolliCell = Corolla Done

--  |         |
--  o   --->  |
--  |         |

dolliCell :: Stack [()tr]tr ()tr
dolliCell = Corolla $ Fork In Done

--              |
--  [o]   --->  o
--   |          |

lolliFrame :: Stack []tr [()tr]tr
lolliFrame = Target NodeDone

--   |          |
--  [o]   --->  o
--   |          |

dolliFrame :: Stack [()tr]tr [()tr]tr
dolliFrame = Target (Exclude NodeDone)

--   |          |
--   |          o
-- [[o]]  --->  |
--   |          o
--   |          |

stacked :: Stack [()tr]tr [[()tr]tr]tr
stacked = (dolliFrame `On` dolliFrame) (In `Fork` Done)

--   |
--  [|]   --->  o
--   |          |

crossed :: Stack ()tr []tr
crossed = stop

-- we can now join things
--
dolliForever = [dolliFrame; dolliForever]cply
nopetope = [crossed, lolliFrame; dolliForever]cply

-- back to unit as fast as possible...
--
stopetope = [crossed, lolliFrame, dolliCell]cply
neverstopetope = [crossed, lolliFrame, dolliCell; neverstopetope]cply
stopetope' = [crossed, lolliFrame; (dolliCell)cplx]cplx
stopetope'' = [crossed, lolliFrame, dolliCell]cplx

--   |          o
-- [[|]]  --->  |
--   |          o
--   |          |

drossed :: Stack ()tr [[]tr]tr
drossed = up stop

-- ################################
-- ############  Niches ###########
-- ################################

--  |          +
--  |          |

-- this is a niche, but assume to be a frame
niche0 :: Stack ()tr []tr
niche0 = {}z

--  |           |
-- [|]          +
--  |           |

-- this is a niche, but assume to be a frame
niche1 :: Stack ()tr [[]tr]tr
niche1 = {()ar=stop; {}z}z

--  |         o   o
-- [|]  --->   \ /
-- [|]          +
--  |           |

-- this is a niche, but assume to be a frame
niche2 :: Stack ()tr [[]tr, []tr]tr
niche2 = {()ar=stop; niche1}z

--                |
--  |         o   o
-- [o]  --->   \ /
-- [|]          +
--  |           |

niche10 :: Stack [()tr]tr [[()tr]tr, []tr]tr
niche10 = {()ar=Exclude NodeDone; Niche stop}z

-- ################################
-- ############  Frames ###########
-- ################################

--   |              |
--  /|\         o   o
-- |[o]|  --->   \ /
-- |[|]|          o
--  \|/           |
--   |

cyclops :: Stack [()tr]tr [[()tr]tr, []tr]tr
cyclops = (niche10)z

-- Stacking, Valence, Affine subtree, Substitute at an affine position

-- counting Units in a tree

valence :: Tree d ~> Nat
{valence []tr} = 0t
{valence [head; tail]tr} = {plus {valence head} {valence tail}}
{valence ()tr} = 1t

-- counting siblings of a tree

nodeValence :: Tree d ~> Nat
{nodeValence []tr} = 0t
{nodeValence [head; tail]tr} = (1+{nodeValence tail})t

-- counting nodes in a tree

nodes :: Tree d ~> Nat
{nodes ()tr} = t
{nodes []tr} = 1t
{nodes [head; tail]tr} = {plus {nodes head} {nodes tail}}

-- nodeValenceAt: given a (multi)pointer, determine the node valences at those positions
--               WHERE     IN
nodeValenceAt :: Tree d ~> Tree e ~> Nat
{nodeValenceAt ()tr tree} = {nodeValence tree}
{nodeValenceAt []tr []tr} = 0t
{nodeValenceAt [head'; tail']tr [head; tail]tr} = {plus {nodeValenceAt head' head} {nodeValenceAt tail' tail}}

-- a pointer is a valence-1 subtree of a tree
-- it is used to mark a unit in a tree where substitution will occur
--
prop Pointers :: Nat ~> Tree d ~> Tree e ~> * where
  Finger :: Pointers 1t ()tr ()tr
  Finished :: Pointers 0t []tr []tr
  ThisWay :: Pointers 1t head' head -> Pointers n tail' tail -> Pointers (1+n)t [head'; tail']tr [head; tail]tr
  ElseWhere :: Pointers n tail' tail -> Pointers n [[]tr; tail']tr [head; tail]tr

-- http://en.wikipedia.org/wiki/Grafting
--
-- graft WHAT      WHERE     IN
graft :: Tree d ~> Tree e ~> Tree f ~> Tree f
{graft what ()tr ()tr} = what
{graft what []tr tr} = tr
{graft what [head'; tail']tr [head; tail]tr} = [{graft what head' head}; {graft what tail' tail}]tr

-- extgraft: extend and graft
--
extgraft :: Tree what ~> Tree wher ~> Tree tree ~> Tree tree'
{extgraft what ()tr ()tr} = what
{extgraft what []tr ()tr} = ()tr
{extgraft what [head; tail]tr ()tr} = {extgrafthor what [head; tail]tr}
{extgraft what []tr []tr} = []tr
{extgraft what []tr [head; tail]tr} = [head; tail]tr
{extgraft what [head'; tail']tr [head; tail]tr} = [{extgraft what head' head}; {extgraft what tail' tail}]tr

-- helper:
extgrafthor :: Tree what ~> Tree Hor ~> Tree Hor
{extgrafthor what []tr} = []tr
{extgrafthor what [head; tail]tr} = [{extgraft what head ()tr}; {extgrafthor what tail}]tr

{- NOTE: we have an Omega bug here:

prompt> :norm {graft []tr ()tr ()tr}
Normalizes to:
  []tr

prompt> :kind []tr
[]tr :: Tree Hor  = []tr

prompt> :kind {graft []tr ()tr ()tr}
{graft []tr ()tr ()tr} :: Tree Ver  = {graft []tr ()tr ()tr}

... BUT: Hor /= Ver :-(
-}

-- substitution: replace a pointed node (of valence n) in a tree with an
-- other tree of (valence n) -- TODO

-- HERE IS A NICE RESEARCH QUESTION:
-- is it possible to "proof search" a Zoom?
-- i.e.
{-

class ZoomLike (int :: Tree) (out :: Tree) where
  zoom :: (Nodes int ~ Valence out) => Zoom int out

-}

prop Reference :: Tree Hor ~> * where
  Stop :: Reference []tr
  Up :: Reference tr -> Reference [tr]tr
 deriving Nat(d) -- de Bruijn index

prop Teleport :: Tree Hor ~> * where
  Gate :: Teleport [()tr]tr
  Tele :: Teleport tr -> Teleport [tr]tr
 deriving Nat(sk) -- skips

{-

0
|   |
1   L  (lambda node)
|   |
2   1  (how many skips)
 \ /
  o
  |
  B  (binds here)
  |

Encodes \x.xx

-}

r2 = 2d
t2 = 1sk

lamX_XX = addBinder $ [r2, t2]ar

prop BindsUp :: Nat ~> Tree Hor ~> * where
  LastSkip :: BindsUp 0t [()tr]tr
  MoreSkip :: Nat' n -> Teleport tr -> BindsUp (1+n)t [tr]tr

-- TODO: make sure that something teleports here
addBinder :: Tree' tr -> Tree' [tr]tr
addBinder term = [term]ar

--TODO: prop Lambda :: Tree Hor ~> * where

{-
The slogan is: binder nodes do not count as result nodes:
 - just consider the next node upstream
 - incoming (external) cards, when identified to a binder do not count as inputs to application
 - incoming (external) cards, when identified to an (iterated) application become pattern matching (sigma).

In the end all identifications have a semantics (hopefully!), when the counting rules are ensured.

-}

-- Modeling Opetopes
-- here is Eric's editor: http://sma.epfl.ch/~finster/opetope/opetope.html
--
-- Note: Kock et al. use a similar scheme, where
--          - dots    <-->   lines
--          - spheres <-->   dots
--          - lines disappear
--          -                spheres appear

-- Note: In Eric's new work (at IAS) there are no
--       dots any more, instead he uses 'external cards', so
--          - (external) cards   <-->  lines
--          - space between stacked cards <--> external cards
--          - lines disappear
--          -                (regular) cards appear

import "../tests/Nat.prg"

-- GLOBAL TODOs
----------------

-- Naming: Seems essential for identifying things Hor(Name), Ver(Tree)
--         Name can be Label, then Niches (= sequences of opetope names).
--         the latter arise from the composition rule.
--         Note: don't store names in Stacks, that kills alpha
--               conversion. Instead names should be pushed into nodes
--               'singleton style' from outside: (node :: Tree (Hor `g))

-- Morphisms: given an opetope and a pointer to one of its cards
--            extract the opetope of that face (do we need a label
--            space to reliably find it?). This must be a type
--            function, with an algorithm accompanying it to extract
--            the face proper.

-- Composition: grafting of trees to external cards, but only if the
--              morphisms (faces) match. lower-dim stuff is unaffected.

-- Swapping: given a proof of equality between two niches, provide an
--           operation to swap them, replacing old faces by new ones,
--           FGL-style (functional graph library), just note that
--           certain morphisms are gone, others appeared.

-- References: a disciplined way of saying "I am an identical node to that guy",
--             by corollary these always obtain the same names.
--             a topologist would say 'surgery' (http://en.wikipedia.org/wiki/Surgery_theory)
--             We get a new Tree flavour, Ref, at least one up, followed by
--             naturals to index a node in a subtree.
--             At this point we are doing algebraic topology, and dealing with
--             closed manifolds, so that we can do homology etc. on them.
--             In logic this corresponds to relations, satisfiability.

-- Quoting: So far we have only dealt with data, i.e. quoted (inert) syntax.
--          we need a way to convert this syntax to code (e.g. at some stage),
--          to obtain semantics. We can have the usual splicing game.
--          Lisp does this with sexprs and macros.
--          The code needs then be executed (run, decreasing stage), when
--          it becomes active, and we can observe the manifestation of its
--          semantics. The reduction system could go along the lines of the
--          (typed) LambdaGraph.

-- NbE: I fully believe we can use this technique to reduce opetopic terms
--      to normal form. ('many syntax', 'one semantics' adjunction:
--                       http://www.logicmatters.net/resources/pdfs/Galois.pdf)

-- TODO: these three must be LeftLists
--
kind Trees = NoTree | Pre (Tree d) Trees deriving syntax (ts) List(NoTree, Pre)

data ZoomCompley :: Tree e ~> Tree f ~> * where
  Nily :: ZoomCompley a a
  Consy :: Stack a b -> ZoomCompley b c -> ZoomCompley a c
 deriving List(cply)

data ZoomComplex :: Trees ~> * where
  Nilx :: ZoomComplex [()tr]ts
  Endx :: Stack a b -> ZoomComplex [a, b]ts
  Consx :: Stack a b -> ZoomComplex [b; c]ts -> ZoomComplex [a, b; c]ts
 deriving syntax (cplx) List(Nilx, Consx) Item(Endx)

data Dir :: *2 where
  Hor :: Dir
  Ver :: Dir

-- define the Tree kind, a rose tree
-- note: we may need a two-level kind, since we need to track disjointness
--       of subtrees
-- todo: later we may want to have a label kind parameter too

data Tree :: Dir ~> *1 where
  Unit :: Tree Ver
  Ni :: Tree Hor
  Fork :: Tree d ~> Tree Hor ~> Tree Hor
 deriving syntax (tr) List(Ni, Fork) Unit(Unit)

-- make it singleton

data Tree' :: Tree d ~> * where
  In :: Tree' ()tr
  Fork :: treelike head -> Tree' tail -> Tree' [head; tail]tr
  Done :: Tree' []tr
 deriving syntax (ar) List(Done, Fork) Unit(In) -- "arbre"
-- http://www.papoulipoesique.com/wp-content/uploads/2013/06/arbre.jpg

-- define a proposition for subtrees
-- to be checked: TakeHead must ensure that all the node is consumed

prop Subtree :: Tree d ~> Tree e ~> * where
  UnitSub :: Subtree ()tr tr
  BothNil :: Subtree []tr []tr
  TakeHead :: Subtree head head' -> Subtree tail tail' -> Subtree [head; tail]tr [head'; tail']tr

-- TODO: separate the notions of Niche / Frame / Cell
kind Volume = FramedHollow | FilledCell
kind Diagram = Closed Volume | OpenNiche
-- should be a parameter to Stack

-- now we can stack cards (these are zooms in Kock et al. parlance)

data Stack :: Tree d ~> Tree e ~> * where
  Corolla :: Corolla tr => Tree' tr -> Stack tr ()tr

  -- TODO: needed?
  --Expand :: (Subtree consumed tr, {nodeValence consumed} `Equal` {nodeValence tr}) => Stack consumed prod -> Stack tr prod

  -- add another target face to a web
  Target :: ({nodes tr} `Equal` {nodeValence out}) => Stack tr out -> Stack tr out

  -- the following three grab a node (and possibly its offsprings) and incorporate it into a single card
  NodeDone :: Stack []tr [()tr]tr
  Pick :: {- EntireNode => -} Stack head prodhead -> Stack tail prodtail -> Stack [head; tail]tr [prodhead; prodtail]tr
  Exclude :: {- EntireNode => -} Stack tail prod -> Stack [()tr; tail]tr prod
  -- TODO: maybe just specify a subtree (Tree') and that's it

  On :: (Subtree tr' tr, Pointers 1t at out) => Stack tr' out' -> Stack tr out -> Tree' at -> Stack tr {graft out' at out}

  -- building niches (pasting diagrams)
  -- TODO: these must produce a composite labelled Hor
  NicheDone :: Stack ()tr []tr
  Niche :: Stack tr out -> Stack tr [out]tr
  Also :: Pointers 1t at tr
       => Tree' at -> Stack tr' out' -> Stack tr out -> Stack {extgraft tr' at tr} [out'; out]tr

  -- put a frame around a niche
  Frame :: (Corolla out, {nodes tr}  `Equal` {nodeValence out}) => Stack tr out -> Stack tr out

 deriving syntax(z) Record(NicheDone, Also) Item(Target)

stop = ({}z)z

-- this is bogus, just make it compile again...
up :: Reference tr => Stack ()tr tr -> Stack ()tr [tr]tr
up inner = ({()ar=inner}z)z

-- it remains to define corollas

-- TODO: one could say {nodes tr} == 1
prop Corolla :: Tree d ~> * where
  None' :: Corolla []tr
  One' :: Corolla tail -> Corolla [()tr; tail]tr

--  o   --->  |
--  |         |

lolliCell :: Stack []tr ()tr
lolliCell = Corolla Done

--  |         |
--  o   --->  |
--  |         |

dolliCell :: Stack [()tr]tr ()tr
dolliCell = Corolla $ Fork In Done

--              |
--  [o]   --->  o
--   |          |

lolliFrame :: Stack []tr [()tr]tr
lolliFrame = Target NodeDone

--   |          |
--  [o]   --->  o
--   |          |

dolliFrame :: Stack [()tr]tr [()tr]tr
dolliFrame = Target (Exclude NodeDone)

--   |          |
--   |          o
-- [[o]]  --->  |
--   |          o
--   |          |

stacked :: Stack [()tr]tr [[()tr]tr]tr
stacked = (dolliFrame `On` dolliFrame) (In `Fork` Done)

--   |
--  [|]   --->  o
--   |          |

crossed :: Stack ()tr []tr
crossed = stop

-- we can now join things
--
dolliForever = [dolliFrame; dolliForever]cply
nopetope = [crossed, lolliFrame; dolliForever]cply

-- back to unit as fast as possible...
--
stopetope = [crossed, lolliFrame, dolliCell]cply
neverstopetope = [crossed, lolliFrame, dolliCell; neverstopetope]cply
stopetope' = [crossed, lolliFrame; (dolliCell)cplx]cplx
stopetope'' = [crossed, lolliFrame, dolliCell]cplx

--   |          o
-- [[|]]  --->  |
--   |          o
--   |          |

drossed :: Stack ()tr [[]tr]tr
drossed = up stop

-- ################################
-- ############  Niches ###########
-- ################################

--  |          +
--  |          |

-- this is a niche, but assume to be a frame
niche0 :: Stack ()tr []tr
niche0 = {}z

--  |           |
-- [|]          +
--  |           |

-- this is a niche, but assume to be a frame
niche1 :: Stack ()tr [[]tr]tr
niche1 = {()ar=stop; {}z}z

--  |         o   o
-- [|]  --->   \ /
-- [|]          +
--  |           |

-- this is a niche, but assume to be a frame
niche2 :: Stack ()tr [[]tr, []tr]tr
niche2 = {()ar=stop; niche1}z

--                |
--  |         o   o
-- [o]  --->   \ /
-- [|]          +
--  |           |

niche10 :: Stack [()tr]tr [[()tr]tr, []tr]tr
niche10 = {()ar=Exclude NodeDone; Niche stop}z

-- ################################
-- ############  Frames ###########
-- ################################

--   |              |
--  /|\         o   o
-- |[o]|  --->   \ /
-- |[|]|          o
--  \|/           |
--   |

cyclops :: Stack [()tr]tr [[()tr]tr, []tr]tr
cyclops = (niche10)z

-- Stacking, Valence, Affine subtree, Substitute at an affine position

-- counting Units in a tree

valence :: Tree d ~> Nat
{valence []tr} = 0t
{valence [head; tail]tr} = {plus {valence head} {valence tail}}
{valence ()tr} = 1t

-- counting siblings of a tree

nodeValence :: Tree d ~> Nat
{nodeValence []tr} = 0t
{nodeValence [head; tail]tr} = (1+{nodeValence tail})t

-- counting nodes in a tree

nodes :: Tree d ~> Nat
{nodes ()tr} = t
{nodes []tr} = 1t
{nodes [head; tail]tr} = {plus {nodes head} {nodes tail}}

-- nodeValenceAt: given a (multi)pointer, determine the node valences at those positions
--               WHERE     IN
nodeValenceAt :: Tree d ~> Tree e ~> Nat
{nodeValenceAt ()tr tree} = {nodeValence tree}
{nodeValenceAt []tr []tr} = 0t
{nodeValenceAt [head'; tail']tr [head; tail]tr} = {plus {nodeValenceAt head' head} {nodeValenceAt tail' tail}}

-- a pointer is a valence-1 subtree of a tree
-- it is used to mark a unit in a tree where substitution will occur
--
prop Pointers :: Nat ~> Tree d ~> Tree e ~> * where
  Finger :: Pointers 1t ()tr ()tr
  Finished :: Pointers 0t []tr []tr
  ThisWay :: Pointers 1t head' head -> Pointers n tail' tail -> Pointers (1+n)t [head'; tail']tr [head; tail]tr
  ElseWhere :: Pointers n tail' tail -> Pointers n [[]tr; tail']tr [head; tail]tr

-- http://en.wikipedia.org/wiki/Grafting
--
-- graft WHAT      WHERE     IN
graft :: Tree d ~> Tree e ~> Tree f ~> Tree f
{graft what ()tr ()tr} = what
{graft what []tr tr} = tr
{graft what [head'; tail']tr [head; tail]tr} = [{graft what head' head}; {graft what tail' tail}]tr

-- extgraft: extend and graft
--
extgraft :: Tree what ~> Tree wher ~> Tree tree ~> Tree tree'
{extgraft what ()tr ()tr} = what
{extgraft what []tr ()tr} = ()tr
{extgraft what [head; tail]tr ()tr} = {extgrafthor what [head; tail]tr}
{extgraft what []tr []tr} = []tr
{extgraft what []tr [head; tail]tr} = [head; tail]tr
{extgraft what [head'; tail']tr [head; tail]tr} = [{extgraft what head' head}; {extgraft what tail' tail}]tr

-- helper:
extgrafthor :: Tree what ~> Tree Hor ~> Tree Hor
{extgrafthor what []tr} = []tr
{extgrafthor what [head; tail]tr} = [{extgraft what head ()tr}; {extgrafthor what tail}]tr

{- NOTE: we have an Omega bug here:

prompt> :norm {graft []tr ()tr ()tr}
Normalizes to:
  []tr

prompt> :kind []tr
[]tr :: Tree Hor  = []tr

prompt> :kind {graft []tr ()tr ()tr}
{graft []tr ()tr ()tr} :: Tree Ver  = {graft []tr ()tr ()tr}

... BUT: Hor /= Ver :-(
-}

-- substitution: replace a pointed node (of valence n) in a tree with an
-- other tree of (valence n) -- TODO

-- HERE IS A NICE RESEARCH QUESTION:
-- is it possible to "proof search" a Zoom?
-- i.e.
{-

class ZoomLike (int :: Tree) (out :: Tree) where
  zoom :: (Nodes int ~ Valence out) => Zoom int out

-}

prop Reference :: Tree Hor ~> * where
  Stop :: Reference []tr
  Up :: Reference tr -> Reference [tr]tr
 deriving Nat(d) -- de Bruijn index

prop Teleport :: Tree Hor ~> * where
  Gate :: Teleport [()tr]tr
  Tele :: Teleport tr -> Teleport [tr]tr
 deriving Nat(sk) -- skips

{-

0
|   |
1   L  (lambda node)
|   |
2   1  (how many skips)
 \ /
  o
  |
  B  (binds here)
  |

Encodes \x.xx

-}

r2 = 2d
t2 = 1sk

lamX_XX = addBinder $ [r2, t2]ar

prop BindsUp :: Nat ~> Tree Hor ~> * where
  LastSkip :: Nat' 1t -> Teleport [()tr]tr -> BindsUp 1t [()tr]tr

-- TODO: make sure that something teleports here
addBinder :: Tree' tr -> Tree' [tr]tr
addBinder term = [term]ar

--TODO: prop Lambda :: Tree Hor ~> * where

{-
The slogan is: binder nodes do not count as result nodes:
 - just consider the next node upstream
 - incoming (external) cards, when identified to a binder do not count as inputs to application
 - incoming (external) cards, when identified to an (iterated) application become pattern matching (sigma).

In the end all identifications have a semantics (hopefully!), when the counting rules are ensured.

-}


fix the Applicative constructor order

fix the Applicative constructor order

-- Modeling Opetopes
-- here is Eric's editor: http://sma.epfl.ch/~finster/opetope/opetope.html
--
-- Note: Kock et al. use a similar scheme, where
--          - dots    <-->   lines
--          - spheres <-->   dots
--          - lines disappear
--          -                spheres appear

-- Note: In Eric's new work (at IAS) there are no
--       dots any more, instead he uses 'external cards', so
--          - (external) cards   <-->  lines
--          - space between stacked cards <--> external cards
--          - lines disappear
--          -                (regular) cards appear

import "../tests/Nat.prg"

-- GLOBAL TODOs
----------------

-- Naming: Seems essential for identifying things Hor(Name), Ver(Tree)
--         Name can be Label, then Niches (= sequences of opetope names).
--         the latter arise from the composition rule.
--         Note: don't store names in Stacks, that kills alpha
--               conversion. Instead names should be pushed into nodes
--               'singleton style' from outside: (node :: Tree (Hor `g))

-- Morphisms: given an opetope and a pointer to one of its cards
--            extract the opetope of that face (do we need a label
--            space to reliably find it?). This must be a type
--            function, with an algorithm accompanying it to extract
--            the face proper.

-- Composition: grafting of trees to external cards, but only if the
--              morphisms (faces) match. lower-dim stuff is unaffected.

-- Swapping: given a proof of equality between two niches, provide an
--           operation to swap them, replacing old faces by new ones,
--           FGL-style (functional graph library), just note that
--           certain morphisms are gone, others appeared.

-- References: a disciplined way of saying "I am an identical node to that guy",
--             by corollary these always obtain the same names.
--             a topologist would say 'surgery' (http://en.wikipedia.org/wiki/Surgery_theory)
--             We get a new Tree flavour, Ref, at least one up, followed by
--             naturals to index a node in a subtree.
--             At this point we are doing algebraic topology, and dealing with
--             closed manifolds, so that we can do homology etc. on them.
--             In logic this corresponds to relations, satisfiability.

-- Quoting: So far we have only dealt with data, i.e. quoted (inert) syntax.
--          we need a way to convert this syntax to code (e.g. at some stage),
--          to obtain semantics. We can have the usual splicing game.
--          Lisp does this with sexprs and macros.
--          The code needs then be executed (run, decreasing stage), when
--          it becomes active, and we can observe the manifestation of its
--          semantics. The reduction system could go along the lines of the
--          (typed) LambdaGraph.

-- NbE: I fully believe we can use this technique to reduce opetopic terms
--      to normal form. ('many syntax', 'one semantics' adjunction:
--                       http://www.logicmatters.net/resources/pdfs/Galois.pdf)

-- TODO: these three must be LeftLists
--
kind Trees = NoTree | Pre (Tree d) Trees deriving syntax (ts) List(NoTree, Pre)

data ZoomCompley :: Tree e ~> Tree f ~> * where
  Nily :: ZoomCompley a a
  Consy :: Stack a b -> ZoomCompley b c -> ZoomCompley a c
 deriving List(cply)

data ZoomComplex :: Trees ~> * where
  Nilx :: ZoomComplex [()tr]ts
  Endx :: Stack a b -> ZoomComplex [a, b]ts
  Consx :: Stack a b -> ZoomComplex [b; c]ts -> ZoomComplex [a, b; c]ts
 deriving syntax (cplx) List(Nilx, Consx) Item(Endx)

data Dir :: *2 where
  Hor :: Dir
  Ver :: Dir

-- define the Tree kind, a rose tree
-- note: we may need a two-level kind, since we need to track disjointness
--       of subtrees
-- todo: later we may want to have a label kind parameter too

data Tree :: Dir ~> *1 where
  Unit :: Tree Ver
  Ni :: Tree Hor
  Fork :: Tree d ~> Tree Hor ~> Tree Hor
 deriving syntax (tr) List(Ni, Fork) Unit(Unit)

-- make it singleton

data Tree' :: Tree d ~> * where
  In :: Tree' ()tr
  Fork :: treelike head -> Tree' tail -> Tree' [head; tail]tr
  Done :: Tree' []tr
 deriving syntax (ar) List(Done, Fork) Unit(In) -- "arbre"
-- http://www.papoulipoesique.com/wp-content/uploads/2013/06/arbre.jpg

-- define a proposition for subtrees
-- to be checked: TakeHead must ensure that all the node is consumed

prop Subtree :: Tree d ~> Tree e ~> * where
  UnitSub :: Subtree ()tr tr
  BothNil :: Subtree []tr []tr
  TakeHead :: Subtree head head' -> Subtree tail tail' -> Subtree [head; tail]tr [head'; tail']tr

-- TODO: separate the notions of Niche / Frame / Cell
kind Volume = FramedHollow | FilledCell
kind Diagram = Closed Volume | OpenNiche
-- should be a parameter to Stack

-- now we can stack cards (these are zooms in Kock et al. parlance)

data Stack :: Tree d ~> Tree e ~> * where
  Corolla :: Corolla tr => Tree' tr -> Stack tr ()tr

  -- TODO: needed?
  --Expand :: (Subtree consumed tr, {nodeValence consumed} `Equal` {nodeValence tr}) => Stack consumed prod -> Stack tr prod

  -- add another target face to a web
  Target :: ({nodes tr} `Equal` {nodeValence out}) => Stack tr out -> Stack tr out

  -- the following three grab a node (and possibly its offsprings) and incorporate it into a single card
  NodeDone :: Stack []tr [()tr]tr
  Pick :: {- EntireNode => -} Stack head prodhead -> Stack tail prodtail -> Stack [head; tail]tr [prodhead; prodtail]tr
  Exclude :: {- EntireNode => -} Stack tail prod -> Stack [()tr; tail]tr prod
  -- TODO: maybe just specify a subtree (Tree') and that's it

  On :: (Subtree tr' tr, Pointers 1t at out) => Stack tr' out' -> Stack tr out -> Tree' at -> Stack tr {graft out' at out}

  -- building niches (pasting diagrams)
  -- TODO: these must produce a composite labelled Hor
  NicheDone :: Stack ()tr []tr
  Niche :: Stack tr out -> Stack tr [out]tr
  Also :: Pointers 1t at tr
       => Tree' at -> Stack tr' out' -> Stack tr out -> Stack {extgraft tr' at tr} [out'; out]tr

  -- put a frame around a niche
  Frame :: (Corolla out, {nodes tr}  `Equal` {nodeValence out}) => Stack tr out -> Stack tr out

 deriving syntax(z) Record(NicheDone, Also) Item(Target)

stop = ({}z)z

-- this is bogus, just make it compile again...
up :: Reference tr => Stack ()tr tr -> Stack ()tr [tr]tr
up inner = ({()ar=inner}z)z

-- it remains to define corollas

-- TODO: one could say {nodes tr} == 1
prop Corolla :: Tree d ~> * where
  None' :: Corolla []tr
  One' :: Corolla tail -> Corolla [()tr; tail]tr

--  o   --->  |
--  |         |

lolliCell :: Stack []tr ()tr
lolliCell = Corolla Done

--  |         |
--  o   --->  |
--  |         |

dolliCell :: Stack [()tr]tr ()tr
dolliCell = Corolla $ Fork In Done

--              |
--  [o]   --->  o
--   |          |

lolliFrame :: Stack []tr [()tr]tr
lolliFrame = Target NodeDone

--   |          |
--  [o]   --->  o
--   |          |

dolliFrame :: Stack [()tr]tr [()tr]tr
dolliFrame = Target (Exclude NodeDone)

--   |          |
--   |          o
-- [[o]]  --->  |
--   |          o
--   |          |

stacked :: Stack [()tr]tr [[()tr]tr]tr
stacked = (dolliFrame `On` dolliFrame) (In `Fork` Done)

--   |
--  [|]   --->  o
--   |          |

crossed :: Stack ()tr []tr
crossed = stop

-- we can now join things
--
dolliForever = [dolliFrame; dolliForever]cply
nopetope = [crossed, lolliFrame; dolliForever]cply

-- back to unit as fast as possible...
--
stopetope = [crossed, lolliFrame, dolliCell]cply
neverstopetope = [crossed, lolliFrame, dolliCell; neverstopetope]cply
stopetope' = [crossed, lolliFrame; (dolliCell)cplx]cplx
stopetope'' = [crossed, lolliFrame, dolliCell]cplx

--   |          o
-- [[|]]  --->  |
--   |          o
--   |          |

drossed :: Stack ()tr [[]tr]tr
drossed = up stop

-- ################################
-- ############  Niches ###########
-- ################################

--  |          +
--  |          |

-- this is a niche, but assume to be a frame
niche0 :: Stack ()tr []tr
niche0 = {}z

--  |           |
-- [|]          +
--  |           |

-- this is a niche, but assume to be a frame
niche1 :: Stack ()tr [[]tr]tr
niche1 = {()ar=stop; {}z}z

--  |         o   o
-- [|]  --->   \ /
-- [|]          +
--  |           |

-- this is a niche, but assume to be a frame
niche2 :: Stack ()tr [[]tr, []tr]tr
niche2 = {()ar=stop; niche1}z

--                |
--  |         o   o
-- [o]  --->   \ /
-- [|]          +
--  |           |

niche10 :: Stack [()tr]tr [[()tr]tr, []tr]tr
niche10 = {()ar=Exclude NodeDone; Niche stop}z

-- ################################
-- ############  Frames ###########
-- ################################

--   |              |
--  /|\         o   o
-- |[o]|  --->   \ /
-- |[|]|          o
--  \|/           |
--   |

cyclops :: Stack [()tr]tr [[()tr]tr, []tr]tr
cyclops = (niche10)z

-- Stacking, Valence, Affine subtree, Substitute at an affine position

-- counting Units in a tree

valence :: Tree d ~> Nat
{valence []tr} = 0t
{valence [head; tail]tr} = {plus {valence head} {valence tail}}
{valence ()tr} = 1t

-- counting siblings of a tree

nodeValence :: Tree d ~> Nat
{nodeValence []tr} = 0t
{nodeValence [head; tail]tr} = (1+{nodeValence tail})t

-- counting nodes in a tree

nodes :: Tree d ~> Nat
{nodes ()tr} = t
{nodes []tr} = 1t
{nodes [head; tail]tr} = {plus {nodes head} {nodes tail}}

-- nodeValenceAt: given a (multi)pointer, determine the node valences at those positions
--               WHERE     IN
nodeValenceAt :: Tree d ~> Tree e ~> Nat
{nodeValenceAt ()tr tree} = {nodeValence tree}
{nodeValenceAt []tr []tr} = 0t
{nodeValenceAt [head'; tail']tr [head; tail]tr} = {plus {nodeValenceAt head' head} {nodeValenceAt tail' tail}}

-- a pointer is a valence-1 subtree of a tree
-- it is used to mark a unit in a tree where substitution will occur
--
prop Pointers :: Nat ~> Tree d ~> Tree e ~> * where
  Finger :: Pointers 1t ()tr ()tr
  Finished :: Pointers 0t []tr []tr
  ThisWay :: Pointers 1t head' head -> Pointers n tail' tail -> Pointers (1+n)t [head'; tail']tr [head; tail]tr
  ElseWhere :: Pointers n tail' tail -> Pointers n [[]tr; tail']tr [head; tail]tr

-- http://en.wikipedia.org/wiki/Grafting
--
-- graft WHAT      WHERE     IN
graft :: Tree d ~> Tree e ~> Tree f ~> Tree f
{graft what ()tr ()tr} = what
{graft what []tr tr} = tr
{graft what [head'; tail']tr [head; tail]tr} = [{graft what head' head}; {graft what tail' tail}]tr

-- extgraft: extend and graft
--
extgraft :: Tree what ~> Tree wher ~> Tree tree ~> Tree tree'
{extgraft what ()tr ()tr} = what
{extgraft what []tr ()tr} = ()tr
{extgraft what [head; tail]tr ()tr} = {extgrafthor what [head; tail]tr}
{extgraft what []tr []tr} = []tr
{extgraft what []tr [head; tail]tr} = [head; tail]tr
{extgraft what [head'; tail']tr [head; tail]tr} = [{extgraft what head' head}; {extgraft what tail' tail}]tr

-- helper:
extgrafthor :: Tree what ~> Tree Hor ~> Tree Hor
{extgrafthor what []tr} = []tr
{extgrafthor what [head; tail]tr} = [{extgraft what head ()tr}; {extgrafthor what tail}]tr

{- NOTE: we have an Omega bug here:

prompt> :norm {graft []tr ()tr ()tr}
Normalizes to:
  []tr

prompt> :kind []tr
[]tr :: Tree Hor  = []tr

prompt> :kind {graft []tr ()tr ()tr}
{graft []tr ()tr ()tr} :: Tree Ver  = {graft []tr ()tr ()tr}

... BUT: Hor /= Ver :-(
-}

-- substitution: replace a pointed node (of valence n) in a tree with an
-- other tree of (valence n) -- TODO

-- HERE IS A NICE RESEARCH QUESTION:
-- is it possible to "proof search" a Zoom?
-- i.e.
{-

class ZoomLike (int :: Tree) (out :: Tree) where
  zoom :: (Nodes int ~ Valence out) => Zoom int out

-}

prop Reference :: Tree Hor ~> * where
  Stop :: Reference []tr
  Up :: Reference tr -> Reference [tr]tr
 deriving Nat(d) -- de Bruijn index

prop Teleport :: Tree Hor ~> * where
  Gate :: Teleport [()tr]tr
  Tele :: Teleport tr -> Teleport [tr]tr
 deriving Nat(sk) -- skips

{-

0
|   |
1   L  (lambda node)
|   |
2   1  (how many skips)
 \ /
  o
  |
  B  (binds here)
  |

Encodes \x.xx

-}

r2 = 2d
t1 = 1sk

lamX_XX = addBinder $ [r2, t1]ar

prop BindsUp :: Nat ~> Tree Hor ~> * where
  LastSkip :: BindsUp 1t [()tr]tr
  MoreSkip :: Teleport tr -> BindsUp n tr -> BindsUp (1+n)t [tr]tr
  -- prove Application node
  HeadBindsUp :: Nat' n -> BindsUp (1+n)t head -> BindsUp n [head; tail]tr
  TailBindsUp :: BindsUp n [head; tail]tr -> BindsUp n [nonempty, head; tail]tr

-- TODO: make sure that something teleports here
addBinder :: BindsUp 1t tr => Tree' tr -> Tree' [tr]tr
addBinder term = [term]ar

testB :: BindsUp 0t [[[[]tr]tr]tr,[()tr]tr]tr -> Tree' [[[[]tr]tr]tr,[()tr]tr]tr
testB ev = [r2, 0sk]ar
testB' = testB (TailBindsUp (HeadBindsUp 0v (LastSkip)))

testC :: BindsUp 0t [[[[[]tr]tr]tr,[[()tr]tr]tr]tr]tr -> Tree' [[[[[]tr]tr]tr,[[()tr]tr]tr]tr]tr
testC ev = lamX_XX
testC' = testC (HeadBindsUp 0v (TailBindsUp (HeadBindsUp 1v (MoreSkip 0sk LastSkip))))

--TODO: prop Lambda :: Tree Hor ~> * where

{-
The slogan is: binder nodes do not count as result nodes:
 - just consider the next node upstream
 - incoming (external) cards, when identified to a binder do not count as inputs to application
 - incoming (external) cards, when identified to an (iterated) application become pattern matching (sigma).

In the end all identifications have a semantics (hopefully!), when the counting rules are ensured.

-}

-- Now some fun stuff

data LC :: * where
  Var :: Label a -> LC
  App :: LC -> LC -> LC
  Lam :: Label a -> LC -> LC
  LetRec :: Label a -> LC -> LC -> LC
 deriving syntax (lc) Applicative(Var, App, Lam, LetRec)

alamX_XX = (\x->x x)lc

-- Modeling Opetopes
-- here is Eric's editor: http://sma.epfl.ch/~finster/opetope/opetope.html
--
-- Note: Kock et al. use a similar scheme, where
--          - dots    <-->   lines
--          - spheres <-->   dots
--          - lines disappear
--          -                spheres appear

-- Note: In Eric's new work (at IAS) there are no
--       dots any more, instead he uses 'external cards', so
--          - (external) cards   <-->  lines
--          - space between stacked cards <--> external cards
--          - lines disappear
--          -                (regular) cards appear

import "../tests/Nat.prg"

-- GLOBAL TODOs
----------------

-- Naming: Seems essential for identifying things Hor(Name), Ver(Tree)
--         Name can be Label, then Niches (= sequences of opetope names).
--         the latter arise from the composition rule.
--         Note: don't store names in Stacks, that kills alpha
--               conversion. Instead names should be pushed into nodes
--               'singleton style' from outside: (node :: Tree (Hor `g))

-- Morphisms: given an opetope and a pointer to one of its cards
--            extract the opetope of that face (do we need a label
--            space to reliably find it?). This must be a type
--            function, with an algorithm accompanying it to extract
--            the face proper.

-- Composition: grafting of trees to external cards, but only if the
--              morphisms (faces) match. lower-dim stuff is unaffected.

-- Swapping: given a proof of equality between two niches, provide an
--           operation to swap them, replacing old faces by new ones,
--           FGL-style (functional graph library), just note that
--           certain morphisms are gone, others appeared.

-- References: a disciplined way of saying "I am an identical node to that guy",
--             by corollary these always obtain the same names.
--             a topologist would say 'surgery' (http://en.wikipedia.org/wiki/Surgery_theory)
--             We get a new Tree flavour, Ref, at least one up, followed by
--             naturals to index a node in a subtree.
--             At this point we are doing algebraic topology, and dealing with
--             closed manifolds, so that we can do homology etc. on them.
--             In logic this corresponds to relations, satisfiability.

-- Quoting: So far we have only dealt with data, i.e. quoted (inert) syntax.
--          we need a way to convert this syntax to code (e.g. at some stage),
--          to obtain semantics. We can have the usual splicing game.
--          Lisp does this with sexprs and macros.
--          The code needs then be executed (run, decreasing stage), when
--          it becomes active, and we can observe the manifestation of its
--          semantics. The reduction system could go along the lines of the
--          (typed) LambdaGraph.

-- NbE: I fully believe we can use this technique to reduce opetopic terms
--      to normal form. ('many syntax', 'one semantics' adjunction:
--                       http://www.logicmatters.net/resources/pdfs/Galois.pdf)

-- TODO: these three must be LeftLists
--
kind Trees = NoTree | Pre (Tree d) Trees deriving syntax (ts) List(NoTree, Pre)

data ZoomCompley :: Tree e ~> Tree f ~> * where
  Nily :: ZoomCompley a a
  Consy :: Stack a b -> ZoomCompley b c -> ZoomCompley a c
 deriving List(cply)

data ZoomComplex :: Trees ~> * where
  Nilx :: ZoomComplex [()tr]ts
  Endx :: Stack a b -> ZoomComplex [a, b]ts
  Consx :: Stack a b -> ZoomComplex [b; c]ts -> ZoomComplex [a, b; c]ts
 deriving syntax (cplx) List(Nilx, Consx) Item(Endx)

data Dir :: *2 where
  Hor :: Dir
  Ver :: Dir

-- define the Tree kind, a rose tree
-- note: we may need a two-level kind, since we need to track disjointness
--       of subtrees
-- todo: later we may want to have a label kind parameter too

data Tree :: Dir ~> *1 where
  Unit :: Tree Ver
  Ni :: Tree Hor
  Fork :: Tree d ~> Tree Hor ~> Tree Hor
 deriving syntax (tr) List(Ni, Fork) Unit(Unit)

-- make it singleton

data Tree' :: Tree d ~> * where
  In :: Tree' ()tr
  Fork :: treelike head -> Tree' tail -> Tree' [head; tail]tr
  Done :: Tree' []tr
 deriving syntax (ar) List(Done, Fork) Unit(In) -- "arbre"
-- http://www.papoulipoesique.com/wp-content/uploads/2013/06/arbre.jpg

-- define a proposition for subtrees
-- to be checked: TakeHead must ensure that all the node is consumed

prop Subtree :: Tree d ~> Tree e ~> * where
  UnitSub :: Subtree ()tr tr
  BothNil :: Subtree []tr []tr
  TakeHead :: Subtree head head' -> Subtree tail tail' -> Subtree [head; tail]tr [head'; tail']tr

-- TODO: separate the notions of Niche / Frame / Cell
kind Volume = FramedHollow | FilledCell
kind Diagram = Closed Volume | OpenNiche
-- should be a parameter to Stack

-- now we can stack cards (these are zooms in Kock et al. parlance)

data Stack :: Tree d ~> Tree e ~> * where
  Corolla :: Corolla tr => Tree' tr -> Stack tr ()tr

  -- TODO: needed?
  --Expand :: (Subtree consumed tr, {nodeValence consumed} `Equal` {nodeValence tr}) => Stack consumed prod -> Stack tr prod

  -- add another target face to a web
  Target :: ({nodes tr} `Equal` {nodeValence out}) => Stack tr out -> Stack tr out

  -- the following three grab a node (and possibly its offsprings) and incorporate it into a single card
  NodeDone :: Stack []tr [()tr]tr
  Pick :: {- EntireNode => -} Stack head prodhead -> Stack tail prodtail -> Stack [head; tail]tr [prodhead; prodtail]tr
  Exclude :: {- EntireNode => -} Stack tail prod -> Stack [()tr; tail]tr prod
  -- TODO: maybe just specify a subtree (Tree') and that's it

  On :: (Subtree tr' tr, Pointers 1t at out) => Stack tr' out' -> Stack tr out -> Tree' at -> Stack tr {graft out' at out}

  -- building niches (pasting diagrams)
  -- TODO: these must produce a composite labelled Hor
  NicheDone :: Stack ()tr []tr
  Niche :: Stack tr out -> Stack tr [out]tr
  Also :: Pointers 1t at tr
       => Tree' at -> Stack tr' out' -> Stack tr out -> Stack {extgraft tr' at tr} [out'; out]tr

  -- put a frame around a niche
  Frame :: (Corolla out, {nodes tr}  `Equal` {nodeValence out}) => Stack tr out -> Stack tr out

 deriving syntax(z) Record(NicheDone, Also) Item(Target)

stop = ({}z)z

-- this is bogus, just make it compile again...
up :: Reference tr => Stack ()tr tr -> Stack ()tr [tr]tr
up inner = ({()ar=inner}z)z

-- it remains to define corollas

-- TODO: one could say {nodes tr} == 1
prop Corolla :: Tree d ~> * where
  None' :: Corolla []tr
  One' :: Corolla tail -> Corolla [()tr; tail]tr

--  o   --->  |
--  |         |

lolliCell :: Stack []tr ()tr
lolliCell = Corolla Done

--  |         |
--  o   --->  |
--  |         |

dolliCell :: Stack [()tr]tr ()tr
dolliCell = Corolla $ Fork In Done

--              |
--  [o]   --->  o
--   |          |

lolliFrame :: Stack []tr [()tr]tr
lolliFrame = Target NodeDone

--   |          |
--  [o]   --->  o
--   |          |

dolliFrame :: Stack [()tr]tr [()tr]tr
dolliFrame = Target (Exclude NodeDone)

--   |          |
--   |          o
-- [[o]]  --->  |
--   |          o
--   |          |

stacked :: Stack [()tr]tr [[()tr]tr]tr
stacked = (dolliFrame `On` dolliFrame) (In `Fork` Done)

--   |
--  [|]   --->  o
--   |          |

crossed :: Stack ()tr []tr
crossed = stop

-- we can now join things
--
dolliForever = [dolliFrame; dolliForever]cply
nopetope = [crossed, lolliFrame; dolliForever]cply

-- back to unit as fast as possible...
--
stopetope = [crossed, lolliFrame, dolliCell]cply
neverstopetope = [crossed, lolliFrame, dolliCell; neverstopetope]cply
stopetope' = [crossed, lolliFrame; (dolliCell)cplx]cplx
stopetope'' = [crossed, lolliFrame, dolliCell]cplx

--   |          o
-- [[|]]  --->  |
--   |          o
--   |          |

drossed :: Stack ()tr [[]tr]tr
drossed = up stop

-- ################################
-- ############  Niches ###########
-- ################################

--  |          +
--  |          |

-- this is a niche, but assume to be a frame
niche0 :: Stack ()tr []tr
niche0 = {}z

--  |           |
-- [|]          +
--  |           |

-- this is a niche, but assume to be a frame
niche1 :: Stack ()tr [[]tr]tr
niche1 = {()ar=stop; {}z}z

--  |         o   o
-- [|]  --->   \ /
-- [|]          +
--  |           |

-- this is a niche, but assume to be a frame
niche2 :: Stack ()tr [[]tr, []tr]tr
niche2 = {()ar=stop; niche1}z

--                |
--  |         o   o
-- [o]  --->   \ /
-- [|]          +
--  |           |

niche10 :: Stack [()tr]tr [[()tr]tr, []tr]tr
niche10 = {()ar=Exclude NodeDone; Niche stop}z

-- ################################
-- ############  Frames ###########
-- ################################

--   |              |
--  /|\         o   o
-- |[o]|  --->   \ /
-- |[|]|          o
--  \|/           |
--   |

cyclops :: Stack [()tr]tr [[()tr]tr, []tr]tr
cyclops = (niche10)z

-- Stacking, Valence, Affine subtree, Substitute at an affine position

-- counting Units in a tree

valence :: Tree d ~> Nat
{valence []tr} = 0t
{valence [head; tail]tr} = {plus {valence head} {valence tail}}
{valence ()tr} = 1t

-- counting siblings of a tree

nodeValence :: Tree d ~> Nat
{nodeValence []tr} = 0t
{nodeValence [head; tail]tr} = (1+{nodeValence tail})t

-- counting nodes in a tree

nodes :: Tree d ~> Nat
{nodes ()tr} = t
{nodes []tr} = 1t
{nodes [head; tail]tr} = {plus {nodes head} {nodes tail}}

-- nodeValenceAt: given a (multi)pointer, determine the node valences at those positions
--               WHERE     IN
nodeValenceAt :: Tree d ~> Tree e ~> Nat
{nodeValenceAt ()tr tree} = {nodeValence tree}
{nodeValenceAt []tr []tr} = 0t
{nodeValenceAt [head'; tail']tr [head; tail]tr} = {plus {nodeValenceAt head' head} {nodeValenceAt tail' tail}}

-- a pointer is a valence-1 subtree of a tree
-- it is used to mark a unit in a tree where substitution will occur
--
prop Pointers :: Nat ~> Tree d ~> Tree e ~> * where
  Finger :: Pointers 1t ()tr ()tr
  Finished :: Pointers 0t []tr []tr
  ThisWay :: Pointers 1t head' head -> Pointers n tail' tail -> Pointers (1+n)t [head'; tail']tr [head; tail]tr
  ElseWhere :: Pointers n tail' tail -> Pointers n [[]tr; tail']tr [head; tail]tr

-- http://en.wikipedia.org/wiki/Grafting
--
-- graft WHAT      WHERE     IN
graft :: Tree d ~> Tree e ~> Tree f ~> Tree f
{graft what ()tr ()tr} = what
{graft what []tr tr} = tr
{graft what [head'; tail']tr [head; tail]tr} = [{graft what head' head}; {graft what tail' tail}]tr

-- extgraft: extend and graft
--
extgraft :: Tree what ~> Tree wher ~> Tree tree ~> Tree tree'
{extgraft what ()tr ()tr} = what
{extgraft what []tr ()tr} = ()tr
{extgraft what [head; tail]tr ()tr} = {extgrafthor what [head; tail]tr}
{extgraft what []tr []tr} = []tr
{extgraft what []tr [head; tail]tr} = [head; tail]tr
{extgraft what [head'; tail']tr [head; tail]tr} = [{extgraft what head' head}; {extgraft what tail' tail}]tr

-- helper:
extgrafthor :: Tree what ~> Tree Hor ~> Tree Hor
{extgrafthor what []tr} = []tr
{extgrafthor what [head; tail]tr} = [{extgraft what head ()tr}; {extgrafthor what tail}]tr

{- NOTE: we have an Omega bug here:

prompt> :norm {graft []tr ()tr ()tr}
Normalizes to:
  []tr

prompt> :kind []tr
[]tr :: Tree Hor  = []tr

prompt> :kind {graft []tr ()tr ()tr}
{graft []tr ()tr ()tr} :: Tree Ver  = {graft []tr ()tr ()tr}

... BUT: Hor /= Ver :-(
-}

-- substitution: replace a pointed node (of valence n) in a tree with an
-- other tree of (valence n) -- TODO

-- HERE IS A NICE RESEARCH QUESTION:
-- is it possible to "proof search" a Zoom?
-- i.e.
{-

class ZoomLike (int :: Tree) (out :: Tree) where
  zoom :: (Nodes int ~ Valence out) => Zoom int out

-}

prop Reference :: Tree Hor ~> * where
  Stop :: Reference []tr
  Up :: Reference tr -> Reference [tr]tr
 deriving Nat(d) -- de Bruijn index

prop Teleport :: Tree Hor ~> * where
  Gate :: Teleport [()tr]tr
  Tele :: Teleport tr -> Teleport [tr]tr
 deriving Nat(sk) -- skips

{-

0
|   |
1   L  (lambda node)
|   |
2   1  (how many skips)
 \ /
  o
  |
  B  (binds here)
  |

Encodes \x.xx

-}

r2 = 2d
t1 = 1sk

lamX_XX = addBinder $ [r2, t1]ar

prop BindsUp :: Nat ~> Tree Hor ~> * where
  LastSkip :: BindsUp 1t [()tr]tr
  MoreSkip :: Teleport tr -> BindsUp n tr -> BindsUp (1+n)t [tr]tr
  -- prove Application node
  HeadBindsUp :: Nat' n -> BindsUp (1+n)t head -> BindsUp n [head; tail]tr
  TailBindsUp :: BindsUp n [head; tail]tr -> BindsUp n [nonempty, head; tail]tr

-- TODO: make sure that something teleports here
addBinder :: BindsUp 1t tr => Tree' tr -> Tree' [tr]tr
addBinder term = [term]ar

testB :: BindsUp 0t [[[[]tr]tr]tr,[()tr]tr]tr -> Tree' [[[[]tr]tr]tr,[()tr]tr]tr
testB ev = [r2, 0sk]ar
testB' = testB (TailBindsUp (HeadBindsUp 0v (LastSkip)))

testC :: BindsUp 0t [[[[[]tr]tr]tr,[[()tr]tr]tr]tr]tr -> Tree' [[[[[]tr]tr]tr,[[()tr]tr]tr]tr]tr
testC ev = lamX_XX
testC' = testC (HeadBindsUp 0v (TailBindsUp (HeadBindsUp 1v (MoreSkip 0sk LastSkip))))

--TODO: prop Lambda :: Tree Hor ~> * where

{-
The slogan is: binder nodes do not count as result nodes:
 - just consider the next node upstream
 - incoming (external) cards, when identified to a binder do not count as inputs to application
 - incoming (external) cards, when identified to an (iterated) application become pattern matching (sigma).

In the end all identifications have a semantics (hopefully!), when the counting rules are ensured.

-}

-- Now some fun stuff

data LC :: * where
  App :: LC -> LC
  Lam :: Label a -> LC -> LC
 deriving syntax (lc) Applicative(Lam, App)


Pointers proposition to mark a leaf

Pointers proposition to mark a leaf

-- Modeling Opetopes
-- here is Eric's editor: http://sma.epfl.ch/~finster/opetope/opetope.html
--
-- Note: Kock et al. use a similar scheme, where
--          - dots    <-->   lines
--          - spheres <-->   dots
--          - lines disappear
--          -                spheres appear

-- Note: In Eric's new work (at IAS) there are no
--       dots any more, instead he uses 'outout cards', so
--          - (output) cards   <-->  lines
--          - space between stacked cards <--> output cards
--          - lines disappear
--          -                (regular) cards appear

--import "../tests/NatList.prg"
import "../tests/Nat.prg"

-- list kind
--kind List = Ni | Co

-- define the Tree kind, a rose tree
-- note: Ni may only appear in Fork second position (TODO: use GADT!)

kind Tree = Unit | Ni | Fork Tree Tree deriving syntax (tr) List(Ni, Fork) Unit(Unit)

-- make it singleton

data Tree' :: Tree ~> * where
  In :: Tree' ()tr
  Fork :: Tree' head -> Tree' tail -> Tree' [head; tail]tr
  Done :: Tree' []tr

-- define a proposition for subtrees
-- to be checked: TakeHead must ensure that all the node is consumed

prop Subtree :: Tree ~> Tree ~> * where
  UnitSub :: Subtree ()tr tr
  BothNil :: Subtree []tr []tr
  TakeHead :: Subtree head head' -> Subtree tail tail' -> Subtree [head; tail]tr [head'; tail']tr
  --SkipHead :: Subtree tail tail' -> Subtree [()tr; tail]tr [head'; tail']tr

-- now we can stack cards (these are zooms in Kock et al. parlance)

data Stack :: Tree ~> Tree ~> * where
  Empty :: Corolla tr => Tree' tr -> Stack tr ()tr
  SubDone :: Stack ()tr []tr
  Subdivision :: Stack ()tr sub -> Stack tr rest -> Stack tr [sub; rest]tr
  Encompass :: Subtree consumed tr => Stack consumed prod -> Stack tr prod
  -- the following three grab a node (and possibly its offsprings) and incorporate it into a single card
  -- [perhaps, note: there may be other cards stacked on this one]
  NodeDone :: Stack []tr [()tr]tr
  Pick :: {- EntireNode => -} Stack head prodhead -> Stack tail prodtail -> Stack [head; tail]tr [prodhead; prodtail]tr
  Exclude :: {- EntireNode => -} Stack tail prod -> Stack [()tr; tail]tr prod
  -- we need a way to sequence cards
  -- MultiCard :: ??? Disjoint a b 0 => Subtree a -> Subtree b -> Stack tr a [proda, prodb]tr

-- it remains to define corollas

prop Corolla :: Tree ~> * where
  None' :: Corolla []tr
  One' :: Corolla tail -> Corolla [()tr; tail]tr

--  o   --->  |
--  |         |

lolliCell :: Stack []tr ()tr
lolliCell = Empty Done

--  |         |
--  o   --->  |
--  |         |

dolliCell :: Stack [()tr]tr ()tr
dolliCell = Empty $ Fork In Done

--              |
--  [o]   --->  o
--   |          |

lolliFrame :: Stack []tr [()tr]tr
lolliFrame = Encompass NodeDone

--   |          |
--  [o]   --->  o
--   |          |

dolliFrame :: Stack [()tr]tr [()tr]tr
dolliFrame = Encompass (Exclude NodeDone)

--    |           o   |
-- | [o] |  --->   \ /
-- | [|] |          o
--    |             |

--cyclops :: Stack [()tr]tr [[]tr, ()tr]tr
--cyclops = Subdivision SubDone (Exclude NodeDone)

-- Stacking, Valence, Affine subtree, Substitute at an affine position

-- Counting Units in a tree

valence :: Tree ~> Nat
{valence []tr} = 0t
{valence [head; tail]tr} = {plus {valence head} {valence tail}}
{valence ()tr} = 1t

-- a pointer is a valence-1 subtree of a tree
-- it is used to mark a unit in a tree where substitution will occur
--
prop Pointers :: Nat ~> Tree ~> Tree ~> * where
  Finger :: Pointers 1t ()tr ()tr
  Finished :: Pointers 0t []tr []tr
  ThisWay :: Pointers 1t head' head -> Pointers 0t tail' tail -> Pointers 1t [head'; tail']tr [head; tail]tr
  ElseWhere :: Pointers 1t tail' tail -> Pointers 1t [[]tr; tail']tr [head; tail]tr

-- Modeling Opetopes
-- here is Eric's editor: http://sma.epfl.ch/~finster/opetope/opetope.html
--
-- Note: Kock et al. use a similar scheme, where
--          - dots    <-->   lines
--          - spheres <-->   dots
--          - lines disappear
--          -                spheres appear

-- Note: In Eric's new work (at IAS) there are no
--       dots any more, instead he uses 'outout cards', so
--          - (output) cards   <-->  lines
--          - space between stacked cards <--> output cards
--          - lines disappear
--          -                (regular) cards appear

import "../tests/NatList.prg"
import "../tests/Nat.prg"

-- list kind
--kind List = Ni | Co

-- define the Tree kind, a rose tree
-- note: Ni may only appear in Fork second position (TODO: use GADT!)

kind Tree = Unit | Ni | Fork Tree Tree deriving syntax (tr) List(Ni, Fork) Unit(Unit)

-- make it singleton

data Tree' :: Tree ~> * where
  In :: Tree' ()tr
  Fork :: Tree' head -> Tree' tail -> Tree' [head; tail]tr
  Done :: Tree' []tr

-- define a proposition for subtrees
-- to be checked: TakeHead must ensure that all the node is consumed

prop Subtree :: Tree ~> Tree ~> * where
  UnitSub :: Subtree ()tr tr
  BothNil :: Subtree []tr []tr
  TakeHead :: Subtree head head' -> Subtree tail tail' -> Subtree [head; tail]tr [head'; tail']tr
  --SkipHead :: Subtree tail tail' -> Subtree [()tr; tail]tr [head'; tail']tr

-- now we can stack cards (these are zooms in Kock et al. parlance)

data Stack :: Tree ~> Tree ~> * where
  Empty :: Corolla tr => Tree' tr -> Stack tr ()tr
  SubDone :: Stack ()tr []tr
  Subdivision :: Stack ()tr sub -> Stack tr rest -> Stack tr [sub; rest]tr
  Encompass :: Subtree consumed tr => Stack consumed prod -> Stack tr prod
  -- the following three grab a node (and possibly its offsprings) and incorporate it into a single card
  -- [perhaps, note: there may be other cards stacked on this one]
  NodeDone :: Stack []tr [()tr]tr
  Pick :: {- EntireNode => -} Stack head prodhead -> Stack tail prodtail -> Stack [head; tail]tr [prodhead; prodtail]tr
  Exclude :: {- EntireNode => -} Stack tail prod -> Stack [()tr; tail]tr prod
  -- we need a way to sequence cards
  -- MultiCard :: ??? Disjoint a b 0 => Subtree a -> Subtree b -> Stack tr a [proda, prodb]tr

-- it remains to define corollas

prop Corolla :: Tree ~> * where
  None' :: Corolla []tr
  One' :: Corolla tail -> Corolla [()tr; tail]tr

--  o   --->  |
--  |         |

lolliCell :: Stack []tr ()tr
lolliCell = Empty Done

--  |         |
--  o   --->  |
--  |         |

dolliCell :: Stack [()tr]tr ()tr
dolliCell = Empty $ Fork In Done

--              |
--  [o]   --->  o
--   |          |

lolliFrame :: Stack []tr [()tr]tr
lolliFrame = Encompass NodeDone

--   |          |
--  [o]   --->  o
--   |          |

dolliFrame :: Stack [()tr]tr [()tr]tr
dolliFrame = Encompass (Exclude NodeDone)

--    |           o   |
-- | [o] |  --->   \ /
-- | [|] |          o
--    |             |

--cyclops :: Stack [()tr]tr [[]tr, ()tr]tr
--cyclops = Subdivision SubDone (Exclude NodeDone)

-- Stacking, Valence, Affine subtree, Substitute at an affine position

-- Counting Units in a Tree

valence :: Tree ~> Nat
{valence []tr} = 0t
{valence [head; tail]tr} = {plus {valence head} {valence tail}}
{valence ()tr} = 1t


Delete test1.prg

Delete test1.prg

   // comment

          /*

      */

// zuzuok

                zzaac

    = 32

///*commentb */  bgbbbb/*ccccc */