(* Kapitel 4 Kenogrammatik *)
fun append l m = l @ m;
fun reduce f u nil = u
|reduce f u (x::xs)=
f x (reduce f u xs);
val flat = reduce append nil;
fun pair x y =(x,y);
fun allpairs xs ys=
flat(map(fn x=> map (pair x) ys) xs);
exception Fromto;
fun fromto n m=
if n>(m+1) then raise Fromto
else if n=m+1 then nil
else n::fromto (n+1) m;
val nlist = fromto 1;
fun member x [] = false
|member x (hd::tl) = (x=hd) orelse member x tl;
fun combine x l = map (fn y => (x,y)) l;
fun remove x [] =[]
|remove x (hd::tl) =
if (x=hd) then remove x tl
else hd::(remove x tl);
fun last l= hd(rev l);
fun kmax ill = max (map max ill)
and max l = max1 0 l
and max1 n [] = n
|max1 n (hd::tl)= if n>hd then max1 n tl
else max1 hd tl;
exception Place;
(*fun pos n [] = raise Place
|pos 1 (hd::tl) = hd
|pos n (hd::tl) =pos (n-1) tl;
*)
fun pos n l =nth(l,n-1);
fun replace item [] w = []
|replace item (hd::tl) w =
if (hd=item) then w::(replace item tl w)
else hd::(replace item tl w);
fun rd []=[]
|rd [x]=[x]
|rd (x::xs) = x::rd(remove x xs);
fun nlistof 0 x = []
|nlistof n x = x::nlistof (n-1) x;
fun fak 0=1
|fak n= n * fak (n-1);
fun choose n k=
(fak n) div ((fak k)* fak (n-k));
fun powers m n=
if n=0 then 1
else if n=1 then m
else m*(powers m (n-1));
type keno = int;
type kseq = keno list;
fun tnf ks =
let
fun pos n [] = raise Nth
|pos 1 (hd::tl) = hd
|pos n (hd::tl) =pos (n-1) tl;
fun firstocc item list =
let
fun place1 item [] n = raise Place
|place1 item (x::xs) n = if item=x then n
else place1 item xs n+1;
in
place1 item list 1
end;
fun nfirst n [] =raise Place
|nfirst 1 (hd::tl)=[hd]
|nfirst n (hd::tl)=hd::nfirst (n-1) tl;
fun tnf1 [] res n k = res
|tnf1 (hd::tl) res 1 k = tnf1 tl [1] 2 2
|tnf1 (hd::tl) res n k =
if member (pos n ks) (nfirst (n-1) ks)
then tnf1 tl
(res@[pos (firstocc (pos n ks) ks) res])(n+1) k
else tnf1 tl
(res@[k]) (n+1) (k+1);
in
tnf1 ks [] 1 1
end;
fun dnf ks =
let
fun count x []= 0
|count x (y::ys)= (if x=y then 1 else 0)+count x ys;
in
flat (map (fn k=> nlistof (count k (tnf ks)) k)
(rd (tnf ks)))
end;
fun pnf ks = (nlistof (length ks - length(rd ks)) 1)@tnf(rd ks);
fun teq a b = (tnf a = tnf b);
fun deq a b = (dnf a = dnf b);
fun peq a b = (pnf a = pnf b);
fun Pcard n = n;
fun sum from to f=
if (from > to) then 0
else (f from) + sum ( from + 1) to f;
fun P (n,1) = 1
|P (n,k) =
if k>n then 0
else if k=n then 1
else P(n-1,k-1) + P(n-k,k);
fun Dcard n = sum 1 n (fn k => P(n,k));
fun S (n,1) = 1
|S (n,k) =
if k>n then 0
else if k=n then 1
else S(n-1,k-1) + k*S(n-1,k);
fun Tcard n = sum 1 n (fn k => S(n,k));
fun Pcontexture n =
map (fn k => (nlistof (n-k) 1)@(nlist k))
(nlist n);
fun allperms []=[]
|allperms [x]=[[x]]
|allperms [x,y]=[[x,y],[y,x]]
|allperms l=
let
fun remov x [] =[]
|remov x (y::ys) = if (x=y) then ys
else y::remov x ys;
fun combine a l=
map (fn x => a::x) l;
in
flat ( map (fn a => combine a (allperms (remov a l)))
l)
end;
fun combine a l=
map (fn x => a::x) l;
fun allsums n 1=[[n]]
|allsums n k=
if (n=k) then [nlistof n 1]
else
flat(map (fn e => combine e (allsums (n-e) (k-1)))
(nlist (n-k+1)));
fun allpartitions n k=
let
fun Exists f [] = false
|Exists f (hd::tl)=
if (f hd) then true
else Exists f tl;
fun remdups [] = []
|remdups (hd::tl)=
if Exists (fn x => (member x tl)) (allperms hd)
then remdups tl
else hd::(remdups tl);
in
remdups (allsums n k)
end;
fun PDconcrete ks =
map (fn p => flat (map (fn k => nlistof (pos k p) k)
(nlist (length (rd ks)))))
(allpartitions (length ks) (length (rd ks)));
fun Dcontexture n =
flat(map PDconcrete (Pcontexture n));
fun DTconcrete ks =
rd(map (fn i => tnf i)
(allperms ks));
fun Tcontexture n=
flat(map DTconcrete (Dcontexture n));
datatype EN = E|N;
fun delta (i,j) z=
if (pos i z) = (pos j z)
then (i,j,E)
else (i,j,N);
type enstruc = (int*int*EN) list list;
(* pairstructure n erzeugt die Struktur der m"oglichen Paare
f"ur eine Sequenz der L"ange n *)
fun pairstructure n =
map (fn j => map (fn i => (i,j))
(fromto 1 (j-1)))
(fromto 1 n);
fun ENstructure z =
map (fn trl => map (fn pair => delta pair z)
trl)
(pairstructure (length z));
fun teq a b = (ENstructure a) = (ENstructure b);
exception Entoks;
fun ENtoKS enstruc =
let
fun entoks1 [] ks = ks
|entoks1 ((f,s,en)::tl) ks =
let
val fir = pos f ks;
val sec = if (length ks< s) then [] else pos s ks;
in
(if (en=E andalso sec=[])
then entoks1 tl (ks@[fir])
else if (en=E andalso member (hd fir) sec)
then entoks1 tl (replace sec ks fir)
else if (en=E andalso not(member (hd fir) sec))
then raise Entoks
else if (en=N andalso sec=[])
then entoks1 tl (ks@[remove (hd fir)
(nlist ((kmax ks)+1:int))])
else if (en=N andalso fir=sec)
then raise Entoks
else if (en=N andalso member (hd fir) sec)
then entoks1 tl (replace sec ks
(remove (hd fir) sec))
else entoks1 tl ks)
end;
in
(flat (entoks1 (flat enstruc) [[1]]))
end;
fun Tref ks = tnf(rev ks);
fun Dref ks = dnf(Tref ks);
fun Pref ks = pnf(Tref ks);
val a=[1,2];
val b=[1,2,3,4];
fun AG ks = length (rd ks);
fun EE (n,k) =
let
fun combinec item list= map (fn x=> item::x) list;
fun max (x : int) y= if x>y then x else y;
fun mkfg from to 0 = [[]]
|mkfg from to step=
flat(map (fn i => combinec i (mkfg (i+1) to (step-1)))
(fromto from (max from to)));
in
mkfg 1 (n+1) k
end;
fun mappat pat template=
map (fn x => pos x template) pat;
fun mkpats a b =
let
fun max (x:int) y= if x>=y then x
else y;
fun free n ([] : int list) = []
|free n (hd::tl) =
if hd<=n then hd::(free n tl)
else [];
fun possperms [] ag=[]
|possperms [x] ag = [[x]]
|possperms rest ag=
flat(map (fn k=> combine k (possperms (remove k rest)
(max k (ag))))
(free (ag+1) rest ));
in
flat
(map (fn e => possperms e (AG a))
(EE (AG a,AG b)))
end;
fun combinea item list=
map (fn x=> item@x) list;
fun kconcat ks1 ks2=
combinea ks1 (map (fn pat => mappat ks2 pat)
(mkpats ks1 ks2));
fun Dconcat a b = dnf(kconcat a b);
fun Pconcat a b = pnf(kconcat a b);
fun Ekard (n,k) =
let
fun max (x: int) y = if x>y then x else y;
fun Xi from to 0 = 1
|Xi from to step=
sum from to (fn i => Xi (i+1) (max to (i+1)) (step-1));
in
Xi 1 (n+1) k
end;
fun NN (a,b) =
let
val M = EE ((AG a),(AG b));
fun e i =pos i M;
fun gn [] = 0
|gn (x::xs) = if (x>((AG a)+1)) then 1+(gn xs)
else gn xs;
in
sum 1 (Ekard(AG a,AG b))
(fn i => (fak (length (e i))) div (fak(1+gn(e i))) )
end;
fun collfits a [] rule = []
|collfits a (b::bs) (rule as (x,y,en))=
if ((en=E) andalso ((pos x a)=(pos (y) b)))
then
b::collfits a bs rule
else if ((en=N) andalso ((pos x a)<>(pos (y) b)))
then
b::collfits a bs rule
else collfits a bs rule;
(*
fun collfits a [] rule = []
|collfits a (b::bs) (rule as (x,y,en))=
if ((en=E) andalso ((pos x a)=(pos (y-(length a)) b)))
then
b::collfits a bs rule
else if ((en=N) andalso ((pos x a)<>(pos (y-(length a)) b)))
then
b::collfits a bs rule
else collfits a bs rule;
*)
fun mapvermat a bs []=bs
|mapvermat a [] enstruc = []
|mapvermat a bs (rule::rules)=
mapvermat a (collfits a bs rule) rules;
fun kligate a b enstruc =
combinea a
(mapvermat a
(map (fn pat => mappat b pat)
(mkpats a b))
enstruc);
(* Kapitel 5 Kenoarithmetik*)
exception Pis;
fun PIS (n,k) = if k=n then raise Pis
else (n,k+1);
fun PTS0 (n,k) = (n+1,k);
fun PTS1 (n,k) = (n+1,k+1);
fun firstocc item list =
let
fun place1 item [] n = raise Place
|place1 item (x::xs) n = if item=x then n
else place1 item xs n+1;
in
place1 item list 1
end;
fun nfirst n [] =raise Place
|nfirst 0 _ = []
|nfirst 1 (hd::tl)=[hd]
|nfirst n (hd::tl)=hd::nfirst (n-1) tl;
fun forall [] p = true
|forall (x::xs) p = if (p x)= false then false
else forall xs p;
exception Dis;
fun DIS D =
if (forall D (fn x => x=1)) then raise Dis
else
let
val m = sum 1 (length D) (fn i => (pos i D))
val i = ((firstocc 1 D) - 1) handle Place => (length D)
val pi = (pos i D)-1
val u = m - (sum 1 (i-1) (fn k => (pos k D)))
val j = u div pi
val rest = u mod pi
val news = map (fn x => pi) (fromto 1 (j-1)) ;
in
(nfirst (i-1) D) @ [pi] @ news @ (if rest=0 then []
else [rest])
end;
fun remnils []=[]
|remnils (hd::tl) = if hd=[] then remnils tl
else hd::(remnils tl);
fun replacepos n list w=
let
exception Replace;
fun replacepos1 n [] x m= raise Replace
|replacepos1 n (hd::tl) x m=
if n=m then x::tl
else hd::(replacepos1 n tl x (m+1));
in
replacepos1 n list w 1
end;
fun DTS D =
[((pos 1 D)+1)::(tl D)] @
(remnils (map (fn i => if (pos i D) > (pos (i+1) D)
then replacepos (i+1) D ((pos (i+1) D)+1)
else [])
(fromto 1 ((length D)-1)))) @
[D@[1]]
datatype 'a seq = Nil
| Cons of 'a * (unit -> 'a seq);
fun head (Cons (x,_))=x;
fun tail (Cons(_,xf))=xf();
fun nfirstq (0, xq)=[]
|nfirstq (n, Nil)=[]
|nfirstq (n, Cons(x,xf))= x::(nfirstq (n-1, xf ()));
fun ifrom k = Cons(k,fn ()=> ifrom(k+1));
exception Tis;
fun TIS ts=
let
val n=length ts;
fun lastrep []=[]
|lastrep seq=
let
fun member x []=false
|member x (y::ys)= (x=y) orelse member x ys;
val (last::rest) = rev seq;
in
if (member last rest) then seq
else lastrep (rev rest)
end;
in
if (pos n ts)=n then raise Tis
else if (last ts) <= (max (nfirst (n-1) ts))
then (nfirst (n-1) ts) @ [1+(last ts)]
else let
val first = rev(lastrep (nfirst (n-1) ts));
in
(rev (tl first))@[1+(hd first)]@(nlistof (n-(length first)) 1)
end
end;
fun Tsucc(ts) = TIS(ts)
handle Tis =>(nlistof ((length ts)+1) 1);
fun from k = Cons(k,fn () => from (Tsucc k));
val TU = from [1];
fun kmul [] b = [[]]
|kmul a [] = [[]]
|kmul a [1] = [a]
|kmul [1] b = [b]
|kmul a b =
let
fun makeEN a k [] = []
|makeEN a k kyet=
flat(map
(fn mem => map
(fn p => (((firstocc mem b)-1)*(length a)+p,
p,
if (k=mem) then E
else N))
(nlist(length a)))
(rd kyet));
fun kmul1 a nil used res = res
|kmul1 a (hd::tl) used res =
kmul1 a tl (hd::used)
(flat(map (fn x => kligate x a
(makeEN a hd used))
res));
in
kmul1 a b [] [[]]
end;
(* Kapitel 6 Morphogrammatik*)
val Q = Tcontexture 4;
exception Mg;
fun mg i = if i<1 orelse i>15 then raise Mg
else pos i Q;
type 'a mat = 'a list list;
fun maufn m n=
let
fun combine it list= map (fn x=> it::x) list;
fun maufn1 n []=[]
|maufn1 0 l =[]
|maufn1 1 l = map (fn x=> [x]) l
|maufn1 p l =
flat(map (fn x => combine x (maufn1 (p-1) (remove x l)))
l);
fun remdups []=[]
|remdups ([x,y]::tl)=
if x=y then remdups tl
else if member [y,x] tl then [x,y]::(remdups(remove [y,x] tl))
else [x,y]::(remdups tl);
in
remdups(maufn1 n (nlist m))
end;
fun matpos i j c=
pos j (pos i c);
fun sort l=
let
exception Assoc;
fun assoc n []= raise Assoc
|assoc n ((k,pair)::tl)=
if n=k then (k,pair)
else assoc n tl;
in
map (fn k=> assoc k l)
(nlist (length l))
end;
fun k (i,j)=((j*(j-1)) div 2)-i+1;
fun subsystems n=
sort(map (fn [i,j] => (k(i,j),[i,j]))
(maufn n 2));
fun LL (w: ''a mat)=
let
val n = length w;
in
tnf(flat (map (fn (k,[i,j])=> [matpos i i w,matpos i j w,
matpos j i w,matpos j j w])
(subsystems n)))
end;
fun set (i,j,x,mat)=
let
fun replacepos n list w=
let
exception Replace;
fun replacepos1 n [] x m= raise Replace
|replacepos1 n (hd::tl) x m=
if n=m then x::tl
else hd::(replacepos1 n tl x (m+1));
in
replacepos1 n list w 1
end;
in
replacepos i mat (replacepos j (pos i mat) x)
end;
fun L_1 kseq =
let
exception Subsystems;
val n = 0.5+sqrt(0.25+real((length kseq) div 2));
val n = if real(floor n) = n then floor n
else raise Subsystems;
val subs = subsystems n;
val mat = nlistof n (nlistof n 0);
fun kstomm [] subs mat=mat
|kstomm (ii::ij::ji::jj::restks)
((k,[i,j])::restpairs)
mat=
kstomm restks
restpairs
(set (i,i,ii,
(set (i,j,ij,
(set (j,i,ji,
(set (j,j,jj, mat))))))))
in
kstomm kseq subs mat
end;
fun TNFMM (w: ''a mat) = L_1(LL w);
type mg = kseq;
type mgchain = mg list;
fun makemg i j c=
tnf [matpos i i c,matpos i j c,matpos j i c,matpos j j c];
fun decompose mm =
let
val n = length mm;
in
map (fn (k,[i,j])=> makemg i j mm)
(subsystems n)
end;
fun makeEN (k,ik,jk) subsystems=
flat(map (fn (l,[il,jl])=>
if il=ik then [((l-1)*4+1,1,E)]
else if il=jk then [((l-1)*4+1,4,E)]
else if jl=jk then [((l-1)*4+4,4,E)]
else if jl=ik then [((l-1)*4+4,1,E)]
else [])
(nfirst (k-1) subsystems));
fun kligs x ys ENS=
flat (map (fn y=> kligate y x ENS)
ys);
fun compose1 [] (subs:(int*int list) list) res subsystems=res
|compose1 (hd::tl) ((k,[ik,jk])::subs) res subsystems=
(compose1 tl
subs
(kligs hd
res
(makeEN (k,ik,jk) subsystems))
subsystems);
fun kstomm [] subs mat=mat
|kstomm (ii::ij::ji::jj::restks) ((k,[i,j])::restpairs) mat=
kstomm restks restpairs
(set (i,i,ii,(set (i,j,ij,(set (j,i,ji,(set (j,j,jj, mat)))))))) ;
fun Kom mk =
let
exception Compose;
val n = 0.5+sqrt(0.25+real(2*(length mk)));
val n = if real(floor n) = n then floor n
else raise Compose;
val mat= nlistof n (nlistof n 1);
val subsystems =subsystems n;
in
map (fn ks=> kstomm ks subsystems mat)
(compose1 mk subsystems [[]] subsystems)
end;
fun remzeros [] = []
|remzeros (0::tl) = remzeros tl
|remzeros (hd::tl) = hd::(remzeros tl);
exception Assoc
fun assoc x [] = raise Assoc
|assoc x ((y,z)::rest) = if x=y then z
else assoc x rest;
fun filter p nil = nil
|filter p (x::xs) =
if p x then x :: filter p xs
else filter p xs;
fun mem xs x = member x xs;
fun difference s t =
filter (not o mem t) s;
fun intersection s t=
filter (mem s) t;
fun seteq a b =
(difference a b)= [] andalso (difference b a) = [];
fun disjuncts subs n=
let
fun intersected sk sl =
let
val subsystems = subsystems n;
val [ik,jk] = assoc sk subsystems;
val [il,jl] = assoc sl subsystems;
in
(il=ik) orelse (il=jk) orelse (jk=jl) orelse (jl=ik)
end;
fun allintersectedwith si =
remzeros(map (fn sj => if (intersected si sj) then sj
else 0)
(subs));
fun allconnectedto sis =
let
val step = rd(flat(map allintersectedwith sis));
in
if (seteq sis step) then sis
else allconnectedto step
end;
fun alldisjunctions [] =[]
|alldisjunctions (hd::tl) =
let
val thisdisj = allconnectedto [hd];
val rest = difference (hd::tl) thisdisj;
in
if rest=[] then [thisdisj]
else thisdisj::(alldisjunctions rest)
end;
in
alldisjunctions subs
end;
fun hauptdiag disj n =
let
val positions = rd (flat (map (fn s => (assoc s (subsystems n)))
disj));
val hdiag = map (fn pos => if (member pos positions) then pos
else 0)
(nlist n);
fun split [] os = (os,[])
|split (0::rest) os = split rest (0::os)
|split x os = (os,x);
val (leados,rest) = split hdiag [];
val (followos,revdisj) = split (rev rest) [];
val revdiag = leados@revdisj@followos
in
map (fn p => if (pos p hdiag)= 0 andalso
(pos p revdiag)= 0 then 0
else p)
(nlist n)
end;
fun alltouchedby disj alldisj n =
let
fun remdups [] res = res
|remdups (hd::tl) res =
if (member hd res) then remdups tl res
else remdups tl (hd::res);
val touched= map k
(remdups (allpairs (remzeros (hauptdiag disj n))
(remzeros (hauptdiag disj n)))
[]);
in
rd(flat(remnils(map (fn disi => if (exists (fn s => member s touched)
disj)
then disi
else [])
alldisj)))
end;
fun allRBs [] n = []
|allRBs (hd::tl) n =
let
val thisRB = hd@(alltouchedby hd tl n);
val rest = difference (flat (hd::tl)) thisRB
in
if rest=[] then [thisRB]
else thisRB::(allRBs (disjuncts rest n) n)
end;
fun reflectRB RB mat=
let
val n = length mat;
fun poke [] m = m
|poke (si::tl) m =
let
val [i,j] = assoc si (subsystems n);
in
poke tl
(set (i,i,pos i (pos i mat),
set (i,j,pos j (pos i mat),
set (j,i,pos i (pos j mat),
set (j,j,pos j (pos j mat),m)))))
end;
fun split [] os = (os,[])
|split (0::rest) os = split rest (0::os)
|split x os = (os,x);
val rhomat = poke RB (nlistof n (nlistof n 0));
val (leados,rest) = split (flat rhomat) [];
val (followos,revrho) = split (rev rest) [];
val flatmat = flat mat;
val flatrhomat = (leados @ revrho @ followos);
exception Nthcdr;
fun nthcdr n [] = raise Nthcdr
|nthcdr 0 liste = liste
|nthcdr n (hd::tl) = nthcdr (n-1) tl;
fun elements n m liste=
nfirst (m-n+1) (nthcdr n liste);
fun mkmat n liste =
map (fn z => elements (z*n) (z*n+n-1) liste)
(fromto 0 (n-1));
in
mkmat n (map (fn i => if (pos i flatrhomat)=0 then (pos i flatmat)
else (pos i flatrhomat))
(nlist (n*n)))
end;
fun reflectall [] mat = mat
|reflectall (RB::rest) mat =
reflectall rest (reflectRB RB mat);
fun r I mat=
reflectall (allRBs (disjuncts I (length mat)) (length mat)) mat;
fun pot [] = [[]]
|pot [x] = [[],[x]]
|pot (hd::tl) =
let
val half = pot tl
in
half@(map (fn l => hd::l)
half)
end;
fun RG n =
map (fn I => r I)
(remnils (pot (rev (nlist (choose n 2)))));
(* Kapitel 7 Klassifikation des Operandensystems*)
datatype fc = F|C;
fun FCstructure hd =
map (fn (k,[i,j]) => if (pos i hd)=(pos j hd) then C
else F)
(subsystems (length hd));
fun allFCs n =
rd(map (fn ks => FCstructure ks)
(Tcontexture n));
fun FCtype mg = if (pos 1 mg)=(pos 4 mg) then C
else F;
fun FCtypes MK =
map (fn mg => FCtype mg)
MK;
fun exmm MK =
if (member (FCtypes MK)
(allFCs (floor(0.5+sqrt(0.25+
real(2*(length MK)))))))
then true
else false;
datatype gh=G|H;
fun ghtyp mg=
if (pos 2 mg)=(pos 3 mg) then H
else G;
fun GHtypes mk = map ghtyp mk;
datatype klor =K|L|O|R;
fun klortyp mg=
if (pos 1 mg) = (pos 4 mg)
then if (pos 2 mg)=(pos 3 mg)
then O
else R
else if (pos 2 mg)=(pos 3 mg)
then L
else K;
fun KLORtypes mk = map klortyp mk;
(*Kapitel 9 Kombinatorische Analyse der Polysemie*)
fun sum from to f=
if (from > to) then 0
else (f from) + sum ( from + 1) to f;
fun S (n,1) = 1
|S (n,k) =
if k>n then 0
else if k=n then 1
else S(n-1,k-1) + k*S(n-1,k);
fun NF m = sum 1 m (fn k => S(m,k));
fun P (n,1) = 1
|P (n,k) =
if k>n then 0
else if k=n then 1
else P(n-1,k-1) + P(n-k,k);
fun GF m = sum 1 m (fn k => P(m,k));
fun fak 0=1
|fak n= n * fak (n-1);
fun choose n k=
(fak n) div ((fak k)* fak (n-k));
fun powers m n=
if n=0 then 1
else if n=1 then m
else m*(powers m (n-1));
fun sigma n11 n12 n13 n22 n23 n24=
let
val l1=n11+n12+n13;
val l2=n22+n23+n24;
in
((fak l1) div ((fak n11)*(fak n12)*(fak n13)))
* (powers 3 n12) *
((fak l2) div ((fak n22)*(fak n23)*(fak n24)))
* (powers 4 n22) * (powers 5 n23)
end;
fun max []=0
|max [x]=x
|max (x::xs)=
let
val restmax = max xs;
in
if (x > restmax) then x else restmax
end;
fun k n= n;
fun RR n11 n12 n13 n22 n23 n24=
let
val kJ = if (n11+n12+n13)=3 then 1
else if (n22+n23+n24)=3 then 3
else 2;
in
max (kJ::(map (fn (n,j,r) => if (n=0) then 0
else (k j)+r)
[(n11,1,0),(n12,1,1),(n13,1,2),
(n22,2,0),(n23,2,1),(n24,2,2)]))
end;
fun M n11 n12 n13 n22 n23 n24=
let
val kJ = if (n11+n12+n13)=3 then 1
else if (n22+n23+n24)=3 then 3
else 2;
in
kJ + n12 + (2*n13) + n23 + (2*n24)
end;
fun dr n2 n3=
if n3<>0 then 2
else if n2<>0 then 1
else 0;
exception A
fun a1 (n1,n2,n3,m,j) =
if (j=1) andalso
((m<(RR n1 n2 n3 0 0 0)) orelse (m>(M n1 n2 n3 0 0 0)))
then 0
else if j=2 andalso
((m<(RR 0 0 0 n1 n2 n3)) orelse (m>(M 0 0 0 n1 n2 n3)))
then 0
else if n1=n1+n2+n3 then 1
else if n3<>0 then
sum 0 (dr n2 n3)
(fn q => (choose (m-(k j)-q) ((dr n2 n3)-q))
*((fak(dr n2 n3)) div (fak q))
*a1(n1+1,n2,n3-1,m-q,j))
else
sum 0 (dr n2 n3)
(fn q => (choose (m-(k j)-q) ((dr n2 n3)-q))
*((fak(dr n2 n3)) div (fak q))
*a1(n1+1,n2-1,n3,m-q,j));
exception B;
fun a (n11,n12,n13,n22,n23,n24,m) =
let
val J = if (n11+n12+n13)=3 then 1
else if (n22+n23+n24)=3 then 3
else if (n11+n12+n13+n22+n23+n24)=3 then 2
else raise A;
in
if (m<(RR n11 n12 n13 n22 n23 n24))
orelse (m>(M n11 n12 n13 n22 n23 n24))
then 0
else if J=1 then a1(n11,n12,n13,m,1)
else if J=3 then a1(n22,n23,n24,m,2)
else if n11=1 andalso n22=2 then 1
else if (n12>0 orelse n13>0) then
sum 0 (dr n12 n13)
(fn q => (choose (m-(k 1)-q) ((dr n12 n13)-q))
*((fak(dr n12 n13)) div (fak q))
*a(n11+1,if n12=0 then 0 else n12-1,
if n13=0 then 0 else n13-1,
n22,n23,n24,m-q))
else if (n24>0) then
sum 0 (dr n23 n24)
(fn q => (choose (m-(k 2)-q) ((dr n23 n24)-q))
*((fak(dr n22 n24)) div (fak q))
*a(n11,n12,n13,n22+1,n23,if n24=0 then 0
else n24-1,m-q))
else if (n23>0) then
sum 0 (dr n23 n24)
(fn q => (choose (m-(k 2)-q) ((dr n23 n24)-q))
*((fak(dr n22 n24)) div (fak q))
*a(n11,n12,n13,n22+1,if n23=0 then 0
else n23-1,n24,m-q))
else raise B
end;
exception Fromto;
fun fromto n m =
if n>m+1 then raise Fromto
else if n=m+1 then nil
else n::fromto (n+1) m;
fun MP n11 n12 n13 n22 n23 n24=
let
val alist =
map (fn m => a(n11,n12,n13,n22,n23,n24,m))
(fromto (RR n11 n12 n13 n22 n23 n24)
(M n11 n12 n13 n22 n23 n24))
in
(map (fn x => (print x ; print " ")) alist;
sum (RR n11 n12 n13 n22 n23 n24) (M n11 n12 n13 n22 n23 n24)
(fn m => a(n11,n12,n13,n22,n23,n24,m)))
end;
(* Ende *)