path: root/tex/context/base/mkxl/mlib-mpf.lmt

if not modules then modules = { } end modules ['mlib-mpf'] = {
    version   = 1.001,
    comment   = "companion to mlib-ctx.mkiv",
    author    = "Hans Hagen, PRAGMA-ADE, Hasselt NL",
    copyright = "PRAGMA ADE / ConTeXt Development Team",
    license   = "see context related readme files",
}

-- moved from mlib-lua:

local type, tostring, tonumber, select, loadstring = type, tostring, tonumber, select, loadstring
local find, gsub = string.find, string.gsub
local concat = table.concat

local formatters   = string.formatters
local lpegmatch    = lpeg.match
local lpegpatterns = lpeg.patterns

local P, S, Ct, Cs, Cc, C = lpeg.P, lpeg.S, lpeg.Ct, lpeg.Cs, lpeg.Cc, lpeg.C

local report_luarun  = logs.reporter("metapost","lua")
local report_script  = logs.reporter("metapost","script")
local report_message = logs.reporter("metapost")

local trace_luarun   = false  trackers.register("metapost.lua",   function(v) trace_luarun = v end)
local trace_script   = false  trackers.register("metapost.script",function(v) trace_script = v end)

local be_tolerant    = true   directives.register("metapost.lua.tolerant", function(v) be_tolerant = v end)

local set    = mp.set
local get    = mp.get
local aux    = mp.aux
local scan   = mp.scan

do

    -- serializers

    local f_integer      = formatters["%i"]
    local f_numeric      = formatters["%F"]

    -- no %n as that can produce -e notation and that is not so nice for scaled but maybe we
    -- should then switch between ... i.e. make a push/pop for the formatters here ... not now.

    local f_integer      = formatters["%i"]
    local f_numeric      = formatters["%F"]
    local f_pair         = formatters["(%F,%F)"]
    local f_ctrl         = formatters["(%F,%F) .. controls (%F,%F) and (%F,%F)"]
    local f_triplet      = formatters["(%F,%F,%F)"]
    local f_quadruple    = formatters["(%F,%F,%F,%F)"]
    local f_transform    = formatters["totransform(%F,%F,%F,%F,%F,%F)"]
    local f_pen          = formatters["(pencircle transformed totransform(%F,%F,%F,%F,%F,%F))"]

    local f_points       = formatters["%p"]
    local f_pair_pt      = formatters["(%p,%p)"]
    local f_ctrl_pt      = formatters["(%p,%p) .. controls (%p,%p) and (%p,%p)"]
    local f_triplet_pt   = formatters["(%p,%p,%p)"]
    local f_quadruple_pt = formatters["(%p,%p,%p,%p)"]

    local r = P('%')  / "percent"
            + P('"')  / "dquote"
            + P('\n') / "crlf"
         -- + P(' ')  / "space"
    local a = Cc("&")
    local q = Cc('"')
    local p = Cs(q * (r * a)^-1 * (a * r * (P(-1) + a) + P(1))^0 * q)

    mp.cleaned = function(s) return lpegmatch(p,s) or s end

    -- management

    -- sometimes we gain (e.g. .5 sec on the sync test)

    local cache = table.makeweak()

    local runscripts = { }
    local runnames   = { }
    local runmodes   = { }
    local nofscripts = 0

    local function registerscript(name,mode,f)
        nofscripts = nofscripts + 1
        if not f then
            f = mode
            mode = "buffered"
        end
        if f then
            runscripts[nofscripts] = f
            runnames[name] = nofscripts
        else
            runscripts[nofscripts] = name
        end
        runmodes[nofscripts] = mode
        if trace_script then
            report_script("registering %s script %a as %i",mode,name,nofscripts)
        end
        return nofscripts
    end

    metapost.registerscript = registerscript

    function metapost.registerdirect(name,f)
        registerscript(name,"direct",f)
    end

    function metapost.registertokens(name,f)
        registerscript(name,"tokens",f)
    end

    function metapost.scriptindex(name)
        local index = runnames[name] or 0
        if trace_script then
            report_script("fetching scriptindex %i of %a",index,name)
        end
        return index
    end

    -- The gbuffer sharing and such is not really needed now but make a dent when
    -- we have a high volume of simpel calls (loops) so we keep it around for a
    -- while.

    local nesting = 0
    local runs    = 0
    local gbuffer = { }
    local buffer  = gbuffer
    local n       = 0

    local function mpdirect(a)
        n = n + 1 buffer[n] = a
    end

    local function mpflush(separator)
        buffer[1] = concat(buffer,separator or "",1,n)
        n = 1
    end

    function metapost.runscript(code)
        nesting = nesting + 1
        runs    = runs + 1

        local index = type(code) == "number"
        local f
        local result

        if index then
            f = runscripts[code]
            if not f then
                report_luarun("%i: bad index: %s",nesting,code)
            elseif trace_luarun then
                report_luarun("%i: index: %i",nesting,code)
            end
            local m = runmodes[code]
            if m == "direct" then
                result = f()
                if trace_luarun then
                    report_luarun("%i: direct: %a",nesting,type(result))
                end
                nesting = nesting - 1
                return result, true -- string and tables as string and objects
            elseif m == "tokens" then
                result = f()
                if trace_luarun then
                    report_luarun("%i: tokens: %a",nesting,type(result))
                end
                nesting = nesting - 1
                return result       -- string and tables as text to be scanned
            else
                if trace_luarun then
                    report_luarun("%i: no mode",nesting)
                end
            end
        else
            if trace_luarun then
                report_luarun("%i: code: %s",nesting,code)
            end
            f = cache[code]
            if not f then
                f = loadstring("return " .. code)
                if f then
                    cache[code] = f
                elseif be_tolerant then
                    f = loadstring(code)
                    if f then
                        cache[code] = f
                    end
                end
            end
        end

        -- returning nil is more efficient and a signal not to scan in mp

        if f then

            local lbuffer, ln

            if nesting == 1 then
                buffer = gbuffer
                n      = 0
            else
                lbuffer = buffer
                ln      = n
                buffer  = { }
                n       = 0
            end

            result = f()
            if result then
                local t = type(result)
                -- we can consider to use the injector for tables but then we need to
                -- check if concatination is expected so best keep this!
                if t == "number" or t == "boolean" then
                    -- native types
                elseif t == "string" or t == "table" then
                    -- (concatenated) passed to scantokens
                else
                    -- scantokens
                    result = tostring(result)
                end
                if trace_luarun then
                    report_luarun("%i: %s result: %s",nesting,t,result)
                end
            elseif n == 0 then
             -- result = ""
                result = nil -- no scantokens done then
                if trace_luarun then
                    report_luarun("%i: no buffered result",nesting)
                end
            elseif n == 1 then
                result = buffer[1]
                if trace_luarun then
                    report_luarun("%i: 1 buffered result: %s",nesting,result)
                end
            else
                -- the space is why we sometimes have collectors
                if nesting == 1 then
                    -- if we had no space we could pass result directly in lmtx
                    result = concat(buffer," ",1,n)
                    if n > 500 or #result > 10000 then
                        gbuffer = { } -- newtable(20,0)
                        lbuffer = gbuffer
                    end
                else
                    -- if we had no space we could pass result directly in lmtx
                    result = concat(buffer," ")
                end
                if trace_luarun then
                    report_luarun("%i: %i buffered results: %s",nesting,n,result)
                end
            end

            if nesting == 1 then
                n = 0
            else
                buffer = lbuffer
                n      = ln
            end

        else
            report_luarun("%i: no result, invalid code: %s",nesting,code)
            result = ""
        end

        nesting = nesting - 1

        return result
    end

    function metapost.nofscriptruns()
        local c = mplib.getcallbackstate()
        return c.count, string.format(
            "%s (file: %s, text: %s, script: %s, log: %s)",
            c.count, c.file, c.text, c.script, c.log
        )
    end

    -- writers

    local function rawmpp(value)
        n = n + 1
        local t = type(value)
        if t == "number" then
            buffer[n] = f_numeric(value)
        elseif t == "string" then
            buffer[n] = value
        elseif t == "table" then
            if #t == 6 then
                buffer[n] = "totransform(" .. concat(value,",") .. ")"
            else
                buffer[n] = "(" .. concat(value,",") .. ")"
            end
        else -- boolean or whatever
            buffer[n] = tostring(value)
        end
    end

    local function mpprint(first,second,...)
        if second == nil then
            if first ~= nil then
                rawmpp(first)
            end
        else
            for i=1,select("#",first,second,...) do
                local value = (select(i,first,second,...))
                if value ~= nil then
                    rawmpp(value)
                end
            end
        end
    end

    local function mpp(value)
        n = n + 1
        local t = type(value)
        if t == "number" then
            buffer[n] = f_numeric(value)
        elseif t == "string" then
            buffer[n] = lpegmatch(p,value)
        elseif t == "table" then
            if #t > 4 then
                buffer[n] = ""
            else
                buffer[n] = "(" .. concat(value,",") .. ")"
            end
        else -- boolean or whatever
            buffer[n] = tostring(value)
        end
    end

    local function mpvprint(first,second,...) -- variable print
        if second == nil then
            if first ~= nil then
                mpp(first)
            end
        else
            for i=1,select("#",first,second,...) do
                local value = (select(i,first,second,...))
                if value ~= nil then
                    mpp(value)
                end
            end
        end
    end

    local function mpstring(value)
        n = n + 1
        buffer[n] = lpegmatch(p,value)
    end

    local function mpboolean(b)
        n = n + 1
        buffer[n] = b and "true" or "false"
    end

    local function mpnumeric(f)
        n = n + 1
        if not f or f == 0 then
            buffer[n] = "0"
        else
            buffer[n] = f_numeric(f)
        end
    end

    local function mpinteger(i)
        n = n + 1
     -- buffer[n] = i and f_integer(i) or "0"
        buffer[n] = i or "0"
    end

    local function mppoints(i)
        n = n + 1
        if not i or i == 0 then
            buffer[n] = "0pt"
        else
            buffer[n] = f_points(i)
        end
    end

    local function mppair(x,y)
        n = n + 1
        if type(x) == "table" then
            buffer[n] = f_pair(x[1],x[2])
        else
            buffer[n] = f_pair(x,y or x)
        end
    end

    local function mppairpoints(x,y)
        n = n + 1
        if type(x) == "table" then
            buffer[n] = f_pair_pt(x[1],x[2])
        else
            buffer[n] = f_pair_pt(x,y or x)
        end
    end

    local function mptriplet(x,y,z)
        n = n + 1
        if type(x) == "table" then
            buffer[n] = f_triplet(x[1],x[2],x[3])
        else
            buffer[n] = f_triplet(x,y,z)
        end
    end

    local function mptripletpoints(x,y,z)
        n = n + 1
        if type(x) == "table" then
            buffer[n] = f_triplet_pt(x[1],x[2],x[3])
        else
            buffer[n] = f_triplet_pt(x,y,z)
        end
    end

    local function mpquadruple(w,x,y,z)
        n = n + 1
        if type(w) == "table" then
            buffer[n] = f_quadruple(w[1],w[2],w[3],w[4])
        else
            buffer[n] = f_quadruple(w,x,y,z)
        end
    end

    local function mpquadruplepoints(w,x,y,z)
        n = n + 1
        if type(w) == "table" then
            buffer[n] = f_quadruple_pt(w[1],w[2],w[3],w[4])
        else
            buffer[n] = f_quadruple_pt(w,x,y,z)
        end
    end

    local function mptransform(x,y,xx,xy,yx,yy)
        n = n + 1
        if type(x) == "table" then
            buffer[n] = f_transform(x[1],x[2],x[3],x[4],x[5],x[6])
        else
            buffer[n] = f_transform(x,y,xx,xy,yx,yy)
        end
    end

    local function mpcolor(c,m,y,k)
        n = n + 1
        if type(c) == "table" then
            local l = #c
            if l == 4 then
                buffer[n] = f_quadruple(c[1],c[2],c[3],c[4])
            elseif l == 3 then
                buffer[n] = f_triplet(c[1],c[2],c[3])
            else
                buffer[n] = f_numeric(c[1])
            end
        else
            if k then
                buffer[n] = f_quadruple(c,m,y,k)
            elseif y then
                buffer[n] = f_triplet(c,m,y)
            else
                buffer[n] = f_numeric(c)
            end
        end
    end

    -- we have three kind of connectors:
    --
    -- .. ... -- (true)

    local function mp_path(f2,f6,t,connector,cycle)
        if type(t) == "table" then
            local tn = #t
            if tn == 1 then
                local t1 = t[1]
                n = n + 1
                if t.pen then
                    buffer[n] = f_pen(unpack(t1))
                else
                    buffer[n] = f2(t1[1],t1[2])
                end
            elseif tn > 0 then
                if connector == true or connector == nil then
                    connector = ".."
                elseif connector == false then
                    connector = "--"
                end
                if cycle == nil then
                    cycle = t.cycle
                    if cycle == nil then
                        cycle = true
                    end
                end
                local six      = connector == ".." -- otherwise we use whatever gets asked for
                local controls = connector         -- whatever
                local a = t[1]
                local b = t[2]
                n = n + 1
                buffer[n] = "("
                n = n + 1
                if six and #a == 6 and #b == 6 then
                    buffer[n] = f6(a[1],a[2],a[5],a[6],b[3],b[4])
                    controls  = ".."
                else
                    buffer[n] = f2(a[1],a[2])
                    controls  = connector
                end
                for i=2,tn-1 do
                    a = b
                    b = t[i+1]
                    n = n + 1
                    buffer[n] = connector
                    n = n + 1
                    if six and #a == 6 and #b == 6 then
                        buffer[n] = f6(a[1],a[2],a[5],a[6],b[3],b[4])
                        controls  = ".."
                    else
                        buffer[n] = f2(a[1],a[2])
                        controls  = connector
                    end
                end
                n = n + 1
                buffer[n] = connector
                a = b
                b = t[1]
                n = n + 1
                if cycle then
                    if six and #a == 6 and #b == 6 then
                        buffer[n] = f6(a[1],a[2],a[5],a[6],b[3],b[4])
                        controls  = ".."
                    else
                        buffer[n] = f2(a[1],a[2])
                        controls  = connector
                    end
                    n = n + 1
                    buffer[n] = connector
                    n = n + 1
                    buffer[n] = "cycle"
                else
                    buffer[n] = f2(a[1],a[2])
                end
                n = n + 1
                buffer[n] = ")"
            end
        end
    end

    local function mppath(...)
        mp_path(f_pair,f_ctrl,...)
    end

    local function mppathpoints(...)
        mp_path(f_pair_pt,f_ctrl_pt,...)
    end

    local function mpsize(t)
        n = n + 1
        buffer[n] = type(t) == "table" and f_numeric(#t) or "0"
    end

    local replacer = lpeg.replacer("@","%%")

    local function mpfprint(fmt,...)
        n = n + 1
        if not find(fmt,"%",1,true) then
            fmt = lpegmatch(replacer,fmt)
        end
        buffer[n] = formatters[fmt](...)
    end

    local function mpquoted(fmt,s,...)
        if s then
            n = n + 1
            if not find(fmt,"%",1,true) then
                fmt = lpegmatch(replacer,fmt)
            end
         -- buffer[n] = '"' .. formatters[fmt](s,...) .. '"'
            buffer[n] = lpegmatch(p,formatters[fmt](s,...))
        elseif fmt then
            n = n + 1
         -- buffer[n] = '"' .. fmt .. '"'
            buffer[n] = lpegmatch(p,fmt)
        else
            -- something is wrong
        end
    end

    aux.direct          = mpdirect
    aux.flush           = mpflush

    aux.print           = mpprint
    aux.vprint          = mpvprint
    aux.boolean         = mpboolean
    aux.string          = mpstring
    aux.numeric         = mpnumeric
    aux.number          = mpnumeric
    aux.integer         = mpinteger
    aux.points          = mppoints
    aux.pair            = mppair
    aux.pairpoints      = mppairpoints
    aux.triplet         = mptriplet
    aux.tripletpoints   = mptripletpoints
    aux.quadruple       = mpquadruple
    aux.quadruplepoints = mpquadruplepoints
    aux.path            = mppath
    aux.pathpoints      = mppathpoints
    aux.size            = mpsize
    aux.fprint          = mpfprint
    aux.quoted          = mpquoted
    aux.transform       = mptransform
    aux.color           = mpcolor

    -- for the moment

    local function mpdraw(lines,list) -- n * 4
        if list then
            local c = #lines
            for i=1,c do
                local ci = lines[i]
                local ni = #ci
                n = n + 1 buffer[n] = i < c and "d(" or "D("
                for j=1,ni,2 do
                    local l = j + 1
                    n = n + 1 buffer[n] = ci[j]
                    n = n + 1 buffer[n] = ","
                    n = n + 1 buffer[n] = ci[l]
                    n = n + 1 buffer[n] = l < ni and ")--(" or ");"
                end
            end
        else
            local l = #lines
            local m = l - 4
            for i=1,l,4 do
                n = n + 1 buffer[n] = i < m and "d(" or "D("
                n = n + 1 buffer[n] = lines[i]
                n = n + 1 buffer[n] = ","
                n = n + 1 buffer[n] = lines[i+1]
                n = n + 1 buffer[n] = ")--("
                n = n + 1 buffer[n] = lines[i+2]
                n = n + 1 buffer[n] = ","
                n = n + 1 buffer[n] = lines[i+3]
                n = n + 1 buffer[n] = ");"
            end
        end
    end

    local function mpfill(lines,list)
        if list then
            local c = #lines
            for i=1,c do
                local ci = lines[i]
                local ni = #ci
                n = n + 1 buffer[n] = i < c and "f(" or "F("
                for j=1,ni,2 do
                    local l = j + 1
                    n = n + 1 buffer[n] = ci[j]
                    n = n + 1 buffer[n] = ","
                    n = n + 1 buffer[n] = ci[l]
                    n = n + 1 buffer[n] = l < ni and ")--(" or ")--C;"
                end
            end
        else
            local l = #lines
            local m = l - 4
            for i=1,l,4 do
                n = n + 1 buffer[n] = i < m and "f(" or "F("
                n = n + 1 buffer[n] = lines[i]
                n = n + 1 buffer[n] = ","
                n = n + 1 buffer[n] = lines[i+1]
                n = n + 1 buffer[n] = ")--("
                n = n + 1 buffer[n] = lines[i+2]
                n = n + 1 buffer[n] = ","
                n = n + 1 buffer[n] = lines[i+3]
                n = n + 1 buffer[n] = ")--C;"
            end
        end
    end

    aux.draw = mpdraw
    aux.fill = mpfill

    for k, v in next, aux do mp[k] = v end

 -- mp.print = table.setmetatablecall(aux, function(t,...)
 --     mpprint(...)
 -- end)

    mp.print = table.setmetatablecall(aux, function(t,first,second,...)
        if second == nil then
            if first ~= nil then
                rawmpp(first)
            end
        else
            for i=1,select("#",first,second,...) do
                local value = (select(i,first,second,...))
                if value ~= nil then
                    rawmpp(value)
                end
            end
        end
    end)

end

do

    local mpnumeric   = mp.numeric
    local scanstring  = scan.string
    local scriptindex = metapost.scriptindex

    function mp.mf_script_index(name)
        local index = scriptindex(name)
     -- report_script("method %i, name %a, index %i",1,name,index)
        mpnumeric(index)
    end

    -- once bootstrapped ... (needs pushed mpx instances)

    metapost.registerdirect("scriptindex",function()
        return scriptindex(scanstring())
    end)

end

function mp.n(t) -- used ?
    return type(t) == "table" and #t or 0
end

do

    -- experiment: names can change

    local mppath     = aux.path
    local mpsize     = aux.size

    local whitespace = lpegpatterns.whitespace
    local newline    = lpegpatterns.newline
    local setsep     = newline^2
    local comment    = (S("#%") + P("--")) * (1-newline)^0 * (whitespace - setsep)^0
    local value      = (1-whitespace)^1 / tonumber
    local entry      = Ct( value * whitespace * value)
    local set        = Ct((entry * (whitespace-setsep)^0 * comment^0)^1)
    local series     = Ct((set * whitespace^0)^1)

    local pattern    = whitespace^0 * series

    local datasets   = { }
    mp.datasets      = datasets

    function mp.dataset(str)
        return lpegmatch(pattern,str)
    end

    function datasets.load(tag,filename)
        if not filename then
            tag, filename = file.basename(tag), tag
        end
        local data = lpegmatch(pattern,io.loaddata(filename) or "")
        datasets[tag] = {
            data = data,
            line = function(n) mppath(data[n or 1]) end,
            size = function()  mpsize(data)         end,
        }
    end

    table.setmetatablecall(datasets,function(t,k,f,...)
        local d = datasets[k]
        local t = type(d)
        if t == "table" then
            d = d[f]
            if type(d) == "function" then
                d(...)
            else
                mpvprint(...)
            end
        elseif t == "function" then
            d(f,...)
        end
    end)

end

-- \startluacode
--     local str = [[
--         10 20 20 20
--         30 40 40 60
--         50 10
--
--         10 10 20 30
--         30 50 40 50
--         50 20 -- the last one
--
--         10 20 % comment
--         20 10
--         30 40 # comment
--         40 20
--         50 10
--     ]]
--
--     MP.myset = mp.dataset(str)
--
--     inspect(MP.myset)
-- \stopluacode
--
-- \startMPpage
--     color c[] ; c[1] := red ; c[2] := green ; c[3] := blue ;
--     for i=1 upto lua("mp.print(mp.n(MP.myset))") :
--         draw lua("mp.path(MP.myset[" & decimal i & "])") withcolor c[i] ;
--     endfor ;
-- \stopMPpage

-- texts:

function mp.report(a,b,c,...)
    if c then
        report_message("%s : %s",a,formatters[(gsub(b,"@","%%"))](c,...))
    elseif b then
        report_message("%s : %s",a,b)
    elseif a then
        report_message("message : %s",a)
    end
end

function mp.flatten(t)
    local tn = #t

    local t1 = t[1]
    local t2 = t[2]
    local t3 = t[3]
    local t4 = t[4]

    for i=1,tn-5,2 do
        local t5 = t[i+4]
        local t6 = t[i+5]
        if t1 == t3 and t3 == t5 and ((t2 <= t4 and t4 <= t6) or (t6 <= t4 and t4 <= t2)) then
            t[i+3] = t2
            t4     = t2
            t[i]   = false
            t[i+1] = false
        elseif t2 == t4 and t4 == t6 and ((t1 <= t3 and t3 <= t5) or (t5 <= t3 and t3 <= t1)) then
            t[i+2] = t1
            t3     = t1
            t[i]   = false
            t[i+1] = false
        end
        t1 = t3
        t2 = t4
        t3 = t5
        t4 = t6
    end

    -- remove duplicates

    local t1 = t[1]
    local t2 = t[2]
    for i=1,tn-2,2 do
        local t3 = t[i+2]
        local t4 = t[i+3]
        if t1 == t3 and t2 == t4 then
            t[i]   = false
            t[i+1] = false
        end
        t1 = t3
        t2 = t4
    end

    -- move coordinates

    local m = 0
    for i=1,tn,2 do
        if t[i] then
            m = m + 1 t[m] = t[i]
            m = m + 1 t[m] = t[i+1]
        end
    end

    -- prune the table (not gc'd)

    for i=tn,m+1,-1 do
        t[i] = nil
    end

    -- safeguard so that we have at least one segment

    if m == 2 then
        t[3] = t[1]
        t[4] = t[2]
    end

end