zOs/REXX.O08/SORTTEST

call mAdd i, 'null', 'eins', 'zwei', 'drei', 'vier', 'fuenf', 'sechs',
           , 'sieben', 'acht', 'neun', 'zehn', 'elf', 'zwölf' ,
           , 'dreizehn', 'vierzehn', 'fuenfzehn', 'sechzehn' , 'siebze'
do cc=0 to 18
    m.i.0 = cc
    say 'sort' cc '**********'
    call sort o, i
    do x=1 to mSize(o)
        k = mAtSq(o,x)
        v = m.k
        say x k v m.v
        end
    end
exit
sort: procedure expose m.
parse arg o, i
    iSz = mSize(i)
    do x=1 to iSz
        m.sort.0.x = i'.' || x
        end
    call sort1 1, o, 'SORT.0', 1 , iSz+1
    m.o.0 = iSZ
    return
endProcedure sort

sort1: procedure expose m.
parse arg nx, o, i, ib, ie
    iSz = ie - ib
    if iSz < 2 then do
        if iSZ = 1 then
            m.o.1 = m.i.ib
        return
        end
    im = (ie + ib) % 2
    bs = 'SORT.'nx
    ms = 'SORT.' || (nx+1)
    call sort1 nx+2, bs, i, ib, im
    call sort1 nx+2, ms, i, im, ie
    bx = 1
    bz = 1 + im - ib
    mx = 1
    mz = 1 + ie - im
    ox = 0
    do while bx < bz & mx < mz
        bk = m.bs.bx
        mk = m.ms.mx
        ox = ox+1
        if m.bk <= m.mk then do
            m.o.ox = bk
            bx = bx + 1
            end
        else do
            m.o.ox = mk
            mx = mx + 1
            end
        end
    do bx=bx to bz-1
        ox = ox + 1
        m.o.ox = m.bs.bx
        end
    do mx=mx to mz-1
        ox = ox + 1
        m.o.ox = m.ms.mx
        end
    return
endProcedure sort1
/* copy m begin ********************************************************
    stem and tree handling
***********************************************************************/
/*--- increase m.m and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
    parse arg m, delta
    if delta = '' then
        m.m = m.m + 1
    else
        m.m = m.m + delta
    return m.m
endProcedure mInc

/*--- increase m.m and return it (also if undefined) -----------------*/
mIncD: procedure expose m.
    parse arg m, delta
    if symbol('m.m') <> 'VAR' then
        m.m = 0
    return mInc(m)
endProcedure mIncD

/*--- return Ky of m ------------------------------------------------*/
mKy: procedure expose m.
    parse arg m
    return m.mKey.m
endProcedure mKy

/*--- return number of children of node m or 0 -----------------------*/
mSize: procedure expose m.
    parse arg m
    if symbol('m.m.0') == 'VAR' then
        return m.m.0
    else
        return 0
endProcedure mSize

/*--- return parent of node m or '' ----------------------------------*/
mPar: procedure expose m.
parse arg m
    dx = lastPos('.', m)
    if dx <= 1 then
        return ''
    else
        return left(m, dx - 1)
endProcedure mPar

/*--- create a new tree root -----------------------------------------*/
mRoot: procedure expose m.
parse arg m, Ky, val
    if m == '' then
        m = 'mRoot.' || mIncD('mRoot.0')
    m.m = val
    m.mKey.m = Ky
    m.m.0 = 0
    return m
endProcedure mRoot

/*--- add one or several values to stem m.m --------------------------*/
mAdd: procedure expose m.
    parse arg m
    ix = mSize(m)
    do ax = 2 to arg()
        ix = ix + 1
        m.m.ix = arg(ax)
        end
    m.m.0 = ix
    return m'.'ix
endProcedure mAdd

/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSeq: procedure expose m.
    parse arg dst, src, begX, endX
    if begX = '' then
        begX = 1
    if endX = '' then
        endX = mSize(src)
    dx = mSize(dst)
    do sx = begX to endX
        dx = dx + 1
        m.dst.dx = m.src.sx
        end
    m.dst.0 = dx
    return dst
endProcedure mAddSeq

/*--- add one value to the stem m.m ----------------------------------*/
mAddNd: procedure expose m.
    parse arg m
    ix = mSize(m)
    do ax = 2 to arg()
        ix = ix + 1
        m.m.ix = arg(ax)
        m.m.ix.0 = 0
        end
    m.m.0 = ix
    return m'.'ix
endProcedure mAddNd

/*--- add one Ky value pair to stem m.m -----------------------------*/
mAddKy: procedure expose m.
    parse arg m, Ky, val
    nn = mAddNd(m, val)
    m.mKey.nn = Ky
    return nn
endProcedure mAddKy

/*--- add one indexable Ky value pair to stem m.m -------------------*/
mAddK1: procedure expose m.
    parse arg m, ky, val
    if symbol('m.mIndex.m.mKey.ky') == 'VAR' then
        call err 'duplicate Ky' ky 'for node' m
    nn = mAddNd(m, val)
    m.mKey.nn = ky
    m.mIndex.m.mKey.ky = nn
    return nn
endProcedure mAddK1

/*--- put value at Ky if it exists otherwise add the node -----------*/
mPut: procedure expose m.
parse arg m, Ky, val
    if symbol('m.mIndex.m.mKey.Ky') == 'VAR' then do
        ch = m.mIndex.m.mKey.Ky
        m.ch = val
        return ch
        end
    else do
        return mAddK1(m, Ky, val)
        end
    return
endProcedure mPut

/*--- return the child of m at the given Ky, '' if not exists -------*/
mAtK1: procedure expose m.
parse arg m, ky
    if symbol('m.mIndex.m.mKey.ky') == 'VAR' then
        return m.mIndex.m.mKey.ky
    else
        return ''
endProcedure mAtK1

/*--- return the value of the child at Ky, fail if not exists -------*/
mVaAtK1: procedure expose m.
parse arg m, Ky
    if symbol('m.mIndex.m.mKey.Ky') ^== 'VAR' then
        call err 'no Ky' Ky 'at node' m
    ch = m.mIndex.m.mKey.Ky
    return m.ch
endProcedure mVaAtK1

/*--- return the value of the first defined ky in the list of nodes
      def if ky isn't defined ---------------------------------------*/
mFirst: procedure expose m.
parse arg Ky, def
    do ax=3 to arg()
        m = arg(ax)
        if symbol('m.mIndex.m.mKey.Ky') == 'VAR' then do
            ch = m.mIndex.m.mKey.Ky
            return m.ch
            end
        end
    return def
endProcedure mFirst

/*--- return the child at sequenceNo seq of node m -------------------*/
mAtSq: procedure expose m.
parse arg m, seq
    if symbol('m.m.seq') ^== 'VAR' then
        return ''
    else
        return m'.'seq
endProcedure mAtSq

/*--- remove all or all after nwSz children --------------------------*/
mRemCh: procedure expose m.
parse arg pa, nwSz
    if nwSz = '' then
        nwSz = 0
    do cx=nwSz+1 to mSize(pa)
        ch = pa'.'cx
        call mRemCh ch
        ky = m.mKey.ch
        drop m.mIndex.pa.mKey.ky m.mKey.ch m.ch m.ch.0
        end
    m.pa.0 = nwSz
    return pa
endProcedure mRemCh

/*--- add to m.dst a (sub)tree of m.src.* ----------------------------*/
mAddTree: procedure expose m.
parse arg dst, src, begX, endX
    if begX = '' then
        begX = 1
    if endX = '' then
        endX = mSize(src)
    do sx=begX to endX
        sCh = src'.'sx
        if symbol('m.mKey.sCh') ^= 'VAR' then do
            dCh = mAddNd(dst, m.sCh)
            end
        else do
            ky = m.mKey.sCh
            if symbol('m.mIndex.src.mKey.ky') ^= 'VAR' then
                dCh = mAddKy(dst, ky, m.sCh)
            else
                dCh = mAddK1(dst, ky, m.sCh)
            end
        call mAddTree dCh, sCh
        end
    return dst
endProcedure mAddTree

/*--- show from one node everything that is defined ------------------*/
mShowNd: procedure expose m.
parse arg m
    pa = mPar(m)
    t = 'node' m 'pa='pa
    if symbol('m.m') == 'VAR' then
        t = t 'va='m.m
    if symbol('m.m.0') == 'VAR' then
        t = t 'size='m.m.0
    if symbol('m.mKey.m') == 'VAR' then do
        ky = m.mKey.m
        t = t 'ky='ky
        if symbol('m.mIndex.pa.mKey.ky') == 'VAR' then
            t = t 'index='m.mIndex.pa.mKey.ky
        end
    say t
    return
endProcedure mShowNd

/*--- show the tree at m recursively ---------------------------------*/
mShow: procedure expose m.
parse arg m, lv
    if lv = '' then
        lv = 0
    t = left('', lv)m
    if symbol('m.mKey.m') == 'VAR' then do
        ky = m.mKey.m
        pa = mPar(m)
        if symbol('m.mIndex.pa.mKey.ky') == 'VAR' then
            t= t ky '>'
        else
            t= t ky '='
        end
    say t strip(m.m, 't')
    do cx=1 to mSize(m)
        call mShow mAtSq(m, cx), lv+1
        end
    return
endProcedure treeShow

/* copy m end *********************************************************/