BEGIN # Multiplicative Digital Roots                                              #
    # structure to hold the results of calculating the digital root & persistence #
    MODE DR = STRUCT( INT root, INT persistence );
    # returns the product of the digits of number                                 #
    OP DIGITPRODUCT = ( INT number )INT:
       BEGIN
            INT    result := 1;
            INT    rest   := number;
            WHILE result TIMESAB ( rest MOD 10 );
                  rest   OVERAB  10;
                  rest > 0
            DO SKIP OD;
            result
       END; # DIGITPRODUCT #
    # calculates the multiplicative digital root and persistence of number        #
    OP MDROOT = ( INT number )DR:
       BEGIN
            INT mp  := 0;
            INT mdr := ABS number;
            WHILE mdr > 9 DO
                mp +:= 1;
                mdr := DIGITPRODUCT mdr
            OD;
            ( mdr, mp )
       END; # MDROOT #
    # prints a number and its MDR and MP                                          #
    PROC print md root = ( INT number )VOID:
         BEGIN
            DR mdr = MDROOT( number );
            print( ( whole( number, -6 ), ": MDR: ", whole( root OF mdr, 0 ), ", MP: ",  whole( persistence OF mdr, -2 ), newline ) )
         END; # print md root #
    # prints the first few numbers with each possible Multiplicative Digital      #
    # Root. The number of values to print is specified as a parameter             #
    PROC tabulate mdr = ( INT number of values )VOID:
         BEGIN
            [ 0 : 9, 1 : number of values ]INT mdr values;
            [ 0 : 9                       ]INT mdr counts;
            mdr counts[ AT 1 ] := ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 );
            # find the first few numbers with each possible mdr                   #
            INT values found    := 0;
            INT required values := 10 * number of values;
            FOR value FROM 0 WHILE values found < required values DO
                DR mdr = MDROOT value;
                IF mdr counts[ root OF mdr ] < number of values THEN
                    # need more values with this multiplicative digital root      #
                    values found              +:= 1;
                    mdr counts[ root OF mdr ] +:= 1;
                    mdr values[ root OF mdr, mdr counts[ root OF mdr ] ] := value
                FI
            OD;
            # print the values #
            print( ( "MDR: [n0..n" + whole( number of values - 1, 0 ) + "]", newline ) );
            print( ( "===  ========", newline ) );
            FOR mdr pos FROM 1 LWB mdr values TO 1 UPB mdr values DO
                STRING separator := ": [";
                print( ( whole( mdr pos, -3 ) ) );
                FOR val pos FROM 2 LWB mdr values TO 2 UPB mdr values DO
                    print( ( separator + whole( mdr values[ mdr pos, val pos ], 0 ) ) );
                    separator := ", "
                OD;
                print( ( "]", newline ) )
            OD
         END; # tabulate mdr #
    # task test cases #
    print md root( 123321 );
    print md root(   7739 );
    print md root(    893 );
    print md root( 899998 );
    tabulate mdr( 5 )
END


begin
    % calculate the Multiplicative Digital Root (mdr) and Multiplicative Persistence (mp) of n %
    procedure getMDR ( integer value  n
                     ; integer result mdr, mp
                     ) ;
    begin
        mp  := 0;
        mdr := abs n;
        while mdr > 9 do begin
           integer v;
           v   := mdr;
           mdr := 1;
           while begin
               mdr := mdr * ( v rem 10 );
               v   := v div 10;
               v > 0
           end do begin end;
           mp := mp + 1;
        end while_mdr_gt_9 ;
    end getMDR ;

    % task test cases %
    write( "       N MDR MP" );
    for n := 123321, 7739, 893, 899998 do begin
        integer mdr, mp;
        getMDR( n, mdr, mp );
        write( s_w := 1, i_w := 8, n, i_w := 3, mdr, i_w := 2, mp )
    end for_n ;

    begin % find the first 5 numbers with each possible MDR %
        integer requiredMdrs;
        requiredMdrs := 5;
        begin
            integer array firstFew ( 0 :: 9, 1 :: requiredMdrs );
            integer array mdrFOund ( 0 :: 9 );
            integer       totalFound, requiredTotal, n;
            for i := 0 until 9 do mdrFound( i ) := 0;
            totalFound    := 0;
            requiredTotal := 10 * requiredMdrs;
            n             := -1;
            while totalFound < requiredTotal do begin
                integer mdr, mp;
                n := n + 1;
                getMDR( n, mdr, mp );
                if mdrFound( mdr ) < requiredMdrs then begin
                    % found another number with this MDR and haven't found enough yet %
                    totalFound                       := totalFound + 1;
                    mdrFound( mdr )                  := mdrFound( mdr ) + 1;
                    firstFew( mdr, mdrFound( mdr ) ) := n
                end if_found_another_MDR
            end while_totalFound_lt_requiredTotal ;
            % print the table of MDRs andnumbers %
            write( "MDR: [n0..n4]" );
            write( "===  ========" );
            for v := 0 until 9 do begin
                write( i_w := 3, s_w := 0, v, ": [" );
                for foundPos := 1 until requiredMdrs do begin
                    if foundPos > 1 then writeon( s_w := 0, ", " );
                    writeon( i_w := 1, s_w := 0, firstFew( v, foundPos ) )
                end for_foundPos ;
                writeon( s_w := 0, "]" )
            end for_v
        end
    end

end.


# Multiplicative Digital Roots

BEGIN {

    printMdrAndMp( 123321 );
    printMdrAndMp(   7739 );
    printMdrAndMp(    893 );
    printMdrAndMp( 899998 );

    tabulateMdr( 5 );

} # BEGIN

function printMdrAndMp( n )
{
    calculateMdrAndMp( n );
    printf( "%6d: MDR: %d, MP: %2d\n", n, MDR, MP );
} # printMdrAndMp

function calculateMdrAndMp( n,                     mdrStr, digit )
{

    MP  = 0;                     # global Multiplicative Persistence
    MDR = ( n < 0 ? -n : n );    # global Multiplicative Digital Root

    while( MDR > 9 )
    {
        MP ++;
        mdrStr = "" MDR;
        MDR    = 1;
        for( digit = 1; digit <= length( mdrStr ); digit ++ )
        {
            MDR *= ( substr( mdrStr, digit, 1 ) * 1 );
        } # for digit
    } # while MDR > 9

} # calculateMdrAndMp

function tabulateMdr( n,                  rqdValues, valueCount, value, pos )
{

    # generate a table of the first n numbers with each possible MDR

    rqdValues  = n * 10;
    valueCount = 0;

    for( value = 0; valueCount < rqdValues; value ++ )
    {
        calculateMdrAndMp( value );
        if( mdrCount[ MDR ] < n )
        {
            # still need another value with this MDR
            valueCount ++;
            mdrCount[ MDR ] ++;
            mdrValues[ MDR ":" mdrCount[ MDR ] ] = value;
        } # if mdrCount[ MDR ] < n
    } # for value

    # print the table

    printf( "MDR: [n0..n%d]\n", n - 1 );
    printf( "===  ========\n" );

    for( pos = 0; pos < 10; pos ++ )
    {
        printf( "%3d:", pos );
        separator = " [";
        for( value = 1; value <= n; value ++ )
        {
            printf( "%s%d", separator, mdrValues[ pos ":" value ] );
            separator = ", "
        } # for value
        printf( "]\n" );
    } # for pos

} # tabulateMdr


#include <stdio.h>

#define twidth 5
#define mdr(rmdr, rmp, n)\
    do { *rmp = 0; _mdr(rmdr, rmp, n); } while (0)

void _mdr(int *rmdr, int *rmp, long long n)
{
    /* Adjust r if 0 case, so we don't return 1 */
    int r = n ? 1 : 0;
    while (n) {
        r *= (n % 10);
        n /= 10;
    }

    (*rmp)++;
    if (r >= 10)
        _mdr(rmdr, rmp, r);
    else
        *rmdr = r;
}

int main(void)
{
    int i, j, vmdr, vmp;
    const int values[] = { 123321, 7739, 893, 899998 };
    const int vsize    = sizeof(values) / sizeof(values[0]);

    /* Initial test values */
    printf("Number    MDR    MP\n");
    for (i = 0; i < vsize; ++i) {
        mdr(&vmdr, &vmp, values[i]);
        printf("%6d   %3d   %3d\n", values[i], vmdr, vmp);
    }

    /* Determine table values */
    int table[10][twidth] = { 0 };
    int tfill[10]         = { 0 };
    int total             = 0;
    for (i = 0; total < 10 * twidth; ++i) {
        mdr(&vmdr, &vmp, i);
        if (tfill[vmdr] < twidth) {
            table[vmdr][tfill[vmdr]++] = i;
            total++;
        }
    }

    /* Print calculated table values */
    printf("\nMDR: [n0..n4]\n");
    for (i = 0; i < 10; ++i) {
        printf("%3d: [", i);
        for (j = 0; j < twidth; ++j)
            printf("%d%s", table[i][j], j != twidth - 1 ? ", " : "");
        printf("]\n");
    }

    return 0;
}


using System;
using System.Collections.Generic;
using System.Linq;

class Program
{
    static Tuple<int, int> DigitalRoot(long num)
    {
        int mp = 0;
        while (num > 9)
        {
            num = num.ToString().ToCharArray().Select(x => x - '0').Aggregate((a, b) => a * b);
            mp++;
        }
        return new Tuple<int, int>(mp, (int)num);
    }
    static void Main(string[] args)
    {
        foreach (long num in new long[] { 123321, 7739, 893, 899998 })
        {
            var t = DigitalRoot(num);
            Console.WriteLine("{0} has multiplicative persistence {1} and multiplicative digital root {2}", num, t.Item1, t.Item2);
        }

        const int twidth = 5;
        List<long>[] table = new List<long>[10];
        for (int i = 0; i < 10; i++)
            table[i] = new List<long>();
        long number = -1;
        while (table.Any(x => x.Count < twidth))
        {
            var t = DigitalRoot(++number);
            if (table[t.Item2].Count < twidth)
                table[t.Item2].Add(number);
        }
        for (int i = 0; i < 10; i++)
            Console.WriteLine(" {0} : [{1}]", i, string.Join(", ", table[i]));
    }
}


digits = iter (n: int) yields (int)
    while n>0 do
        yield(n//10)
        n := n/10
    end
end digits

mdr = proc (n: int) returns (int,int)
    i: int := 0
    while n>=10 do
        m: int := 1
        for d: int in digits(n) do
            m := m * d
        end
        n := m
        i := i+1
    end
    return (i,n)
end mdr

first_mdr = iter (target_mdr, n: int) yields (int)
    i: int := 0
    while n>0 do
        x, m: int := mdr(i)
        if m=target_mdr then
            yield(i)
            n := n -1
        end
        i := i+1
    end
end first_mdr

start_up = proc ()
    po: stream := stream$primary_output()
    nums: sequence[int] := sequence[int]$[123321, 7739, 893, 899998]

    stream$putl(po, "  N     MDR  MP")
    stream$putl(po, "======  ===  ==")
    for num: int in sequence[int]$elements(nums) do
        stream$putright(po, int$unparse(num), 6)
        stream$puts(po, " ")
        i, m: int := mdr(num)
        stream$putright(po, int$unparse(m), 3)
        stream$puts(po, "  ")
        stream$putright(po, int$unparse(i), 3)
        stream$putl(po, "")
    end

    stream$putl(po, "\nMDR: [n0..n4]")
    stream$putl(po, "===  ========")
    for dgt: int in int$from_to(0,9) do
        stream$putright(po, int$unparse(dgt), 3)
        stream$puts(po, ": ")
        for num: int in first_mdr(dgt, 5) do
            stream$puts(po, int$unparse(num) || " ")
        end
        stream$putl(po, "")
    end
end start_up


(defun mdr/p (n)
  "Return a list with MDR and MP of n"
  (if (< n 10)
    (list n 0)
    (mdr/p-aux n 1 1)))

(defun mdr/p-aux (n a c)
  (cond ((and (zerop n) (< a 10)) (list a c))
	((zerop n) (mdr/p-aux a 1 (+ c 1)))
	(t (mdr/p-aux (floor n 10) (* (rem n 10) a) c))))

(defun first-n-number-for-each-root (n &optional (r 0) (lst nil) (c 0))
  "Return the first m number with MDR = 0 to 9"
  (cond ((and (= (length lst) n) (= r 9)) (format t "[email protected]: ~a~%" r (reverse lst)))
	((= (length lst) n) (format t "[email protected]: ~a~%" r (reverse lst))
	                    (first-n-number-for-each-root n (+ r 1) nil 0))
	((= (first (mdr/p c)) r) (first-n-number-for-each-root n r (cons c lst) (+ c 1)))
	(t (first-n-number-for-each-root n r lst (+ c 1)))))

(defun start ()
  (format t "Number: MDR  MD~%")
  (loop for el in '(123321 7739 893 899998)
        do (format t "[email protected]: ~{[email protected] ~}~%" el (mdr/p el)))
  (format t "~%MDR: [n0..n4]~%")
  (first-n-number-for-each-root 5))


MODULE MDR;
IMPORT StdLog, Strings, TextMappers, DevCommanders;

PROCEDURE CalcMDR(x: LONGINT; OUT mdr, mp: LONGINT);
VAR
	str: ARRAY 64 OF CHAR;
	i: INTEGER;
BEGIN
	mdr := 1; mp := 0;
	LOOP
		Strings.IntToString(x,str);
		IF LEN(str$) = 1 THEN mdr := x; EXIT END;
		i := 0;mdr := 1;
		WHILE i < LEN(str$) DO
			mdr := mdr * (ORD(str[i]) - ORD('0'));
			INC(i)
		END;
		INC(mp);
		x := mdr
	END
END CalcMDR;

PROCEDURE Do*;
VAR
	mdr,mp: LONGINT;
	s: TextMappers.Scanner;
BEGIN
	s.ConnectTo(DevCommanders.par.text);
	s.SetPos(DevCommanders.par.beg);
	REPEAT
		s.Scan;
		IF (s.type = TextMappers.int) OR (s.type = TextMappers.lint) THEN
			CalcMDR(s.int,mdr,mp);
			StdLog.Int(s.int);
			StdLog.String(" MDR: ");StdLog.Int(mdr);
			StdLog.String(" MP: ");StdLog.Int(mp);StdLog.Ln
		END
	UNTIL s.rider.eot;
END Do;

PROCEDURE Show(i: INTEGER; x: ARRAY OF LONGINT);
VAR
	k: INTEGER;
BEGIN
	StdLog.Int(i);StdLog.String(": ");
	FOR k := 0 TO LEN(x) - 1 DO
		StdLog.Int(x[k])
	END;
	StdLog.Ln
END Show;

PROCEDURE FirstFive*;
VAR
	i,j: INTEGER;
	five: ARRAY 5 OF LONGINT;
	x,mdr,mp: LONGINT;
BEGIN
	FOR i := 0 TO 9 DO
		j := 0;x := 0;
		WHILE (j < LEN(five)) DO
			CalcMDR(x,mdr,mp);
			IF mdr = i THEN five[j] := x; INC(j) END;
			INC(x)
		END;
		Show(i,five)
	END
END FirstFive;

END MDR.


import std.stdio, std.algorithm, std.typecons, std.range, std.conv;

/// Multiplicative digital root.
auto mdRoot(in int n) pure /*nothrow*/ {
    auto mdr = [n];
    while (mdr.back > 9)
        mdr ~= reduce!q{a * b}(1, mdr.back.text.map!(d => d - '0'));
        //mdr ~= mdr.back.text.map!(d => d - '0').mul;
        //mdr ~= mdr.back.reverseDigits.mul;
    return tuple(mdr.length - 1, mdr.back);
}

void main() {
    "Number: (MP, MDR)\n======  =========".writeln;
    foreach (immutable n; [123321, 7739, 893, 899998])
        writefln("%6d: (%s, %s)", n, n.mdRoot[]);

    auto table = (int[]).init.repeat.enumerate!int.take(10).assocArray;
    auto n = 0;
    while (table.byValue.map!walkLength.reduce!min < 5) {
        table[n.mdRoot[1]] ~= n;
        n++;
    }
    "\nMP: [n0..n4]\n==  ========".writeln;
    foreach (const mp; table.byKey.array.sort())
        writefln("%2d: %s", mp, table[mp].take(5));
}


defmodule Digital do
  def mdroot(n), do: mdroot(n, 0)

  defp mdroot(n, persist) when n < 10, do: {n, persist}
  defp mdroot(n, persist), do: mdroot(product(n, 1), persist+1)

  defp product(0, prod), do: prod
  defp product(n, prod), do: product(div(n, 10), prod*rem(n, 10))

  def task1(data) do
    IO.puts "Number: MDR  MP\n======  ===  =="
    Enum.each(data, fn n ->
      {mdr, persist} = mdroot(n)
      :io.format "~6w:   ~w  ~2w~n", [n, mdr, persist]
    end)
  end

  def task2(m \\ 5) do
    IO.puts "\nMDR: [n0..n#{m-1}]\n===  ========"
    map = add_map(0, m, Map.new)
    Enum.each(0..9, fn i ->
      first = map[i] |> Enum.reverse |> Enum.take(m)
      IO.puts "  #{i}: #{inspect first}"
    end)
  end

  defp add_map(n, m, map) do
    {mdr, _persist} = mdroot(n)
    new_map = Map.update(map, mdr, [n], fn vals -> [n | vals] end)
    min_len = Map.values(new_map) |> Enum.map(&length(&1)) |> Enum.min
    if min_len < m, do: add_map(n+1, m, new_map),
                  else: new_map
  end
end

Digital.task1([123321, 7739, 893, 899998])
Digital.task2


// mdr. Nigel Galloway: June 29th., 2021
let rec fG n g=if n=0 then g else fG(n/10)(g*(n%10))
let mdr n=let rec mdr n g=if n<10 then (n,g) else mdr(fG n 1)(g+1) in mdr n 0
[123321; 7739; 893; 899998] |> List.iter(fun i->let n,g=mdr i in printfn "%d has mdr=%d with persitance %d" i n g)
let fN g=Seq.initInfinite id|>Seq.filter((mdr>>fst>>(=)g))|>Seq.take 5
seq{0..9}|>Seq.iter(fun n->printf "First 5 numbers with mdr %d -> " n; Seq.initInfinite id|>Seq.filter((mdr>>fst>>(=)n))|>Seq.take 5|>Seq.iter(printf "%d ");printfn "")


USING: arrays formatting fry io kernel lists lists.lazy math
math.text.utils prettyprint sequences ;
IN: rosetta-code.multiplicative-digital-root

: mdr ( n -- {persistence,root} )
    0 swap
    [ 1 digit-groups dup length 1 > ] [ product [ 1 + ] dip ] while
    dup empty? [ drop { 0 } ] when first 2array ;

: print-mdr ( n -- )
    dup [ 1array ] dip mdr append
    "%-12d has multiplicative persistence %d and MDR %d.\n"
    vprintf ;

: first5 ( n -- seq ) ! first 5 numbers with MDR of n
    0 lfrom swap '[ mdr second _ = ] lfilter 5 swap ltake list>array ;

: print-first5 ( i n -- )
    "%-5d" printf bl first5 [ "%-5d " printf ] each nl ;

: header ( -- )
    "MDR | First five numbers with that MDR" print
    "--------------------------------------" print ;

: first5-table ( -- )
    header 10 iota [ print-first5 ] each-index ;

: main ( -- )
    { 123321 7739 893 899998 } [ print-mdr ] each nl first5-table ;

MAIN: main


!Implemented by Anant Dixit (Oct, 2014)
program mdr
implicit none
integer :: i, mdr, mp, n, j
character(len=*), parameter :: hfmt = '(A18)', nfmt = '(I6)'
character(len=*), parameter :: cfmt = '(A3)', rfmt = '(I3)', ffmt = '(I9)'

write(*,hfmt) 'Number   MDR   MP '
write(*,*) '------------------'

i = 123321
call root_pers(i,mdr,mp)
write(*,nfmt,advance='no') i
write(*,cfmt,advance='no') '   '
write(*,rfmt,advance='no') mdr
write(*,cfmt,advance='no') '   '
write(*,rfmt) mp

i = 3939
call root_pers(i,mdr,mp)
write(*,nfmt,advance='no') i
write(*,cfmt,advance='no') '   '
write(*,rfmt,advance='no') mdr
write(*,cfmt,advance='no') '   '
write(*,rfmt) mp

i = 8822
call root_pers(i,mdr,mp)
write(*,nfmt,advance='no') i
write(*,cfmt,advance='no') '   '
write(*,rfmt,advance='no') mdr
write(*,cfmt,advance='no') '   '
write(*,rfmt) mp

i = 39398
call root_pers(i,mdr,mp)
write(*,nfmt,advance='no') i
write(*,cfmt,advance='no') '   '
write(*,rfmt,advance='no') mdr
write(*,cfmt,advance='no') '   '
write(*,rfmt) mp

write(*,*)
write(*,*)
write(*,*) 'First five numbers with MDR in first column: '
write(*,*) '---------------------------------------------'

do i = 0,9
  n = 0
  j = 0
  write(*,rfmt,advance='no') i
  do
    call root_pers(j,mdr,mp)
    if(mdr.eq.i) then
      n = n+1
      if(n.eq.5) then
        write(*,ffmt) j
        exit
      else
        write(*,ffmt,advance='no') j
      end if
    end if
    j = j+1
  end do
end do

end program

subroutine root_pers(i,mdr,mp)
implicit none
integer :: N, s, a, i, mdr, mp
n = i
a = 0
if(n.lt.10) then
  mdr = n
  mp = 0
  return
end if
do while(n.ge.10)
  a = a + 1
  s = 1
  do while(n.gt.0)
    s = s * mod(n,10)
    n = int(real(n)/10.0D0)
  end do
  n = s
end do
mdr = s
mp = a
end subroutine


' FB 1.05.0 Win64

Function multDigitalRoot(n As UInteger, ByRef mp As Integer, base_ As Integer = 10) As Integer
  Dim mdr As Integer
  mp = 0
  Do
    mdr = IIf(n > 0, 1, 0)
    While n > 0
      mdr *= n Mod base_
      n = n \ base_
    Wend
    mp += 1
    n = mdr
  Loop until mdr < base_
  Return mdr
End Function

Dim As Integer mdr, mp
Dim a(3) As UInteger = {123321, 7739, 893, 899998}
For i As UInteger = 0 To 3
 mp = 0
 mdr = multDigitalRoot(a(i), mp)
 Print a(i); Tab(10); "MDR ="; mdr; Tab(20); "MP ="; mp
 Print
Next
Print
Print "MDR    1     2     3     4     5"
Print "===  ==========================="
Print
Dim num(0 To 9, 0 To 5) As UInteger '' all zero by default
Dim As UInteger n = 0, count = 0
Do
  mdr = multDigitalRoot(n, mp)
  If num(mdr, 0) < 5 Then
    num(mdr, 0) += 1
    num(mdr, num(mdr, 0)) = n
    count += 1
  End If
  n += 1
Loop Until count = 50

For i As UInteger = 0 To 9
  Print i; ":" ;
  For j As UInteger = 1 To 5
    Print Using "######"; num(i, j);
  Next j
  Print
Next i

Print
Print "Press any key to quit"
Sleep


package main

import "fmt"

// Only valid for n > 0 && base >= 2
func mult(n uint64, base int) (mult uint64) {
	for mult = 1; mult > 0 && n > 0; n /= uint64(base) {
		mult *= n % uint64(base)
	}
	return
}

// Only valid for n >= 0 && base >= 2
func MultDigitalRoot(n uint64, base int) (mp, mdr int) {
	var m uint64
	for m = n; m >= uint64(base); mp++ {
		m = mult(m, base)
	}
	return mp, int(m)
}

func main() {
	const base = 10
	const size = 5

	const testFmt = "%20v %3v %3v\n"
	fmt.Printf(testFmt, "Number", "MDR", "MP")
	for _, n := range [...]uint64{
		123321, 7739, 893, 899998,
		18446743999999999999,
		// From http://mathworld.wolfram.com/MultiplicativePersistence.html
		3778888999, 277777788888899,
	} {
		mp, mdr := MultDigitalRoot(n, base)
		fmt.Printf(testFmt, n, mdr, mp)
	}
	fmt.Println()

	var list [base][]uint64
	for i := range list {
		list[i] = make([]uint64, 0, size)
	}
	for cnt, n := size*base, uint64(0); cnt > 0; n++ {
		_, mdr := MultDigitalRoot(n, base)
		if len(list[mdr]) < size {
			list[mdr] = append(list[mdr], n)
			cnt--
		}
	}
	const tableFmt = "%3v: %v\n"
	fmt.Printf(tableFmt, "MDR", "First")
	for i, l := range list {
		fmt.Printf(tableFmt, i, l)
	}
}


F throw_die(n_sides, n_dice, s, [Int] &counts)
   I n_dice == 0
      counts[s]++
      R
   L(i) 1..n_sides
      throw_die(n_sides, n_dice - 1, s + i, counts)

F beating_probability(n_sides1, n_dice1,
                      n_sides2, n_dice2)
   V len1 = (n_sides1 + 1) * n_dice1
   V C1 = [0] * len1
   throw_die(n_sides1, n_dice1, 0, &C1)

   V len2 = (n_sides2 + 1) * n_dice2
   V C2 = [0] * len2
   throw_die(n_sides2, n_dice2, 0, &C2)

   Float p12 = (n_sides1 ^ n_dice1) * (n_sides2 ^ n_dice2)

   V tot = 0.0
   L(i) 0 .< len1
      L(j) 0 .< min(i, len2)
         tot += Float(C1[i]) * C2[j] / p12
   R tot

print(‘#.16’.format(beating_probability(4, 9, 6, 6)))
print(‘#.16’.format(beating_probability(10, 5, 7, 6)))


import Control.Arrow
import Data.Array
import Data.LazyArray
import Data.List (unfoldr)
import Data.Tuple
import Text.Printf

-- The multiplicative persistence (MP) and multiplicative digital root (MDR) of
-- the argument.
mpmdr :: Integer -> (Int, Integer)
mpmdr = (length *** head) . span (> 9) . iterate (product . digits)

-- Pairs (mdr, ns) where mdr is a multiplicative digital root and ns are the
-- first k numbers having that root.
mdrNums :: Int -> [(Integer, [Integer])]
mdrNums k = assocs $ lArrayMap (take k) (0,9) [(snd $ mpmdr n, n) | n <- [0..]]

digits :: Integral t => t -> [t]
digits 0 = [0]
digits n = unfoldr step n
  where step 0 = Nothing
        step k = Just (swap $ quotRem k 10)

printMpMdrs :: [Integer] -> IO ()
printMpMdrs ns = do
  putStrLn "Number MP MDR"
  putStrLn "====== == ==="
  sequence_ [printf "%6d %2d %2d\n" n p r | n <- ns, let (p,r) = mpmdr n]

printMdrNums:: Int -> IO ()
printMdrNums k = do
  putStrLn "MDR Numbers"
  putStrLn "=== ======="
  let showNums = unwords . map show
  sequence_ [printf "%2d  %s\n" mdr $ showNums ns | (mdr,ns) <- mdrNums k]

main :: IO ()
main = do
  printMpMdrs [123321, 7739, 893, 899998]
  putStrLn ""
  printMdrNums 5


INCLUDE "D2:REAL.ACT" ;from the Action! Tool Kit

BYTE FUNC Roll(BYTE sides,dices)
  BYTE i,sum

  sum=0
  FOR i=1 TO dices
  DO
    sum==+Rand(sides)+1
  OD
RETURN (sum)

PROC Test(BYTE sides1,dices1,sides2,dices2)
  INT i,count=[10000],sum1,sum2,wins1,wins2,draws
  REAL r1,r2,p

  wins1=0 wins2=0 draws=0
  FOR i=1 TO count
  DO
    sum1=Roll(sides1,dices1)
    sum2=Roll(sides2,dices2)
    IF sum1>sum2 THEN
      wins1==+1
    ELSEIF sum1<sum2 THEN
      wins2==+1
    ELSE
      draws==+1
    FI
  OD

  IntToReal(wins1,r1)
  IntToReal(wins2,r2)
  RealDiv(r2,r1,p)

  PrintF("Tested %I times%E",count)
  PrintF("Player 1 with %B dice of %B sides%E",dices1,sides1)
  PrintF("Player 2 with %B dice of %B sides%E",dices2,sides2)
  PrintF("Player 1 wins %I times%E",wins1)
  PrintF("Player 2 wins %I times%E",wins2)
  PrintF("Draw %I times%E",draws)
  Print("Player 1 beating Player 2 probability:")
  PrintRE(p)
  PutE()
RETURN

PROC Main()
  Put(125) PutE() ;clear the screen

  Test(4,9,6,6)
  Test(10,5,7,6)
RETURN


with Ada.Text_IO; use Ada.Text_IO;
with Ada.Numerics.Discrete_Random;

procedure Main is
   package real_io is new Float_IO (Long_Float);
   use real_io;

   type Dice is record
      Faces    : Positive;
      Num_Dice : Positive;
   end record;

   procedure Roll_Dice (The_Dice : in Dice; Count : out Natural) is
      subtype Faces is Integer range 1 .. The_Dice.Faces;
      package Die_Random is new Ada.Numerics.Discrete_Random (Faces);
      use Die_Random;
      Seed : Generator;
   begin
      Reset (Seed);
      Count := 0;
      for I in 1 .. The_Dice.Num_Dice loop
         Count := Count + Random (Seed);
      end loop;
   end Roll_Dice;

   function Win_Prob
     (Dice_1 : Dice; Dice_2 : Dice; Tries : Positive) return Long_Float
   is
      Count_1      : Natural := 0;
      Count_2      : Natural := 0;
      Count_1_Wins : Natural := 0;
   begin
      for I in 1 .. Tries loop
         Roll_Dice (Dice_1, Count_1);
         Roll_Dice (Dice_2, Count_2);
         if Count_1 > Count_2 then
            Count_1_Wins := Count_1_Wins + 1;
         end if;
      end loop;
      return Long_Float (Count_1_Wins) / Long_Float (Tries);
   end Win_Prob;

   D1 : Dice := (Faces => 4, Num_Dice => 9);
   D2 : Dice := (Faces => 6, Num_Dice => 6);
   D3 : Dice := (Faces => 10, Num_Dice => 5);
   D4 : Dice := (Faces => 7, Num_Dice => 6);

   P1 : Long_Float := Win_Prob (D1, D2, 1_000_000);
   P2 : Long_Float := Win_Prob (D3, D4, 1_000_000);
begin
   Put ("Dice D1 wins = ");
   Put (Item => P1, Fore => 1, Aft => 7, Exp => 0);
   New_Line;
   Put ("Dice D2 wins = ");
   Put (Item => P2, Fore => 1, Aft => 7, Exp => 0);
   New_Line;
end Main;


procedure main(A)
    write(right("n",8)," ",right("MP",8),right("MDR",5))
    every r := mdr(n := 123321|7739|893|899998) do
        write(right(n,8),":",right(r[1],8),right(r[2],5))
    write()
    write(right("MDR",5),"  ","[n0..n4]")
    every m := 0 to 9 do {
        writes(right(m,5),": [")
        every writes(right((m = mdr(n := seq(m))[2],.n)\5,6))
        write("]")
        }
end

procedure mdr(m)
    i := 0
    while (.m > 10, m := multd(m), i+:=1)
    return [i,m]
end

procedure multd(m)
    c := 1
    while m > 0 do c *:= 1(m%10, m/:=10)
    return c
end


dado1 = 9: lado1 = 4
dado2 = 6: lado2 = 6
total1 = 0: total2 = 0

for i = 0 to 1
    for cont = 1 to 100000
        jugador1 = lanzamiento(dado1, lado1)
        jugador2 = lanzamiento(dado2, lado2)
        if jugador1 > jugador2 then
            total1 = total1 + 1
        else
            if jugador1 <> jugador2 then total2 = total2 + 1
        endif
    next cont

    print "Lanzado el dado "; (cont - 1); " veces"
    print "jugador1 con "; dado1; " dados de "; lado1; " lados"
    print "jugador2 con "; dado2; " dados de "; lado2; " lados"
    print "Total victorias jugador1 = "; total1; " => "; left(string(total2 / total1), 9)
    print "Total victorias jugador2 = "; total2
    print (cont - 1) - (total1 + total2); " empates" + chr(10)

    dado1 = 5: lado1 = 10
    dado2 = 6: lado2 = 7
    total1 = 0: total2 = 0
next i
end

function  lanzamiento(dado, lado)
    total = 0

    for lanza = 1 to dado
        total = total + int(rand * lado) + 1
    next lanza
    return total
end function


#include <stdio.h>
#include <stdint.h>

typedef uint32_t uint;
typedef uint64_t ulong;

ulong ipow(const uint x, const uint y) {
    ulong result = 1;
    for (uint i = 1; i <= y; i++)
        result *= x;
    return result;
}

uint min(const uint x, const uint y) {
    return (x < y) ? x : y;
}

void throw_die(const uint n_sides, const uint n_dice, const uint s, uint counts[]) {
    if (n_dice == 0) {
        counts[s]++;
        return;
    }

    for (uint i = 1; i < n_sides + 1; i++)
        throw_die(n_sides, n_dice - 1, s + i, counts);
}

double beating_probability(const uint n_sides1, const uint n_dice1,
                           const uint n_sides2, const uint n_dice2) {
    const uint len1 = (n_sides1 + 1) * n_dice1;
    uint C1[len1];
    for (uint i = 0; i < len1; i++)
        C1[i] = 0;
    throw_die(n_sides1, n_dice1, 0, C1);

    const uint len2 = (n_sides2 + 1) * n_dice2;
    uint C2[len2];
    for (uint j = 0; j < len2; j++)
        C2[j] = 0;
    throw_die(n_sides2, n_dice2, 0, C2);

    const double p12 = (double)(ipow(n_sides1, n_dice1) * ipow(n_sides2, n_dice2));

    double tot = 0;
    for (uint i = 0; i < len1; i++)
        for (uint j = 0; j < min(i, len2); j++)
            tot += (double)C1[i] * C2[j] / p12;
    return tot;
}

int main() {
    printf("%1.16f\n", beating_probability(4, 9, 6, 6));
    printf("%1.16f\n", beating_probability(10, 5, 7, 6));
    return 0;
}


import java.util.*;

public class MultiplicativeDigitalRoot {

    public static void main(String[] args) {

        System.out.println("NUMBER  MDR   MP");
        for (long n : new long[]{123321, 7739, 893, 899998}) {
            long[] a = multiplicativeDigitalRoot(n);
            System.out.printf("%6d %4d %4d%n", a[0], a[1], a[2]);
        }

        System.out.println();

        Map<Long, List<Long>> table = new HashMap<>();
        for (long i = 0; i < 10; i++)
            table.put(i, new ArrayList<>());

        for (long cnt = 0, n = 0; cnt < 10;) {
            long[] res = multiplicativeDigitalRoot(n++);
            List<Long> list = table.get(res[1]);
            if (list.size() < 5) {
                list.add(res[0]);
                cnt = list.size() == 5 ? cnt + 1 : cnt;
            }
        }

        System.out.println("MDR: first five numbers with same MDR");
        table.forEach((key, lst) -> {
            System.out.printf("%3d: ", key);
            lst.forEach(e -> System.out.printf("%6s ", e));
            System.out.println();
        });
    }

    public static long[] multiplicativeDigitalRoot(long n) {
        int mp = 0;
        long mdr = n;
        while (mdr > 9) {
            long m = mdr;
            long total = 1;
            while (m > 0) {
                total *= m % 10;
                m /= 10;
            }
            mdr = total;
            mp++;
        }
        return new long[]{n, mdr, mp};
    }
}


#include <cmath>
#include <cstdint>
#include <iomanip>
#include <iostream>
#include <map>

// Returns map from sum of faces to number of ways it can happen
std::map<uint32_t, uint32_t> get_totals(uint32_t dice, uint32_t faces) {
    std::map<uint32_t, uint32_t> result;
    for (uint32_t i = 1; i <= faces; ++i)
        result.emplace(i, 1);
    for (uint32_t d = 2; d <= dice; ++d) {
        std::map<uint32_t, uint32_t> tmp;
        for (const auto& p : result) {
            for (uint32_t i = 1; i <= faces; ++i)
                tmp[p.first + i] += p.second;
        }
        tmp.swap(result);
    }
    return result;
}

double probability(uint32_t dice1, uint32_t faces1, uint32_t dice2, uint32_t faces2) {
    auto totals1 = get_totals(dice1, faces1);
    auto totals2 = get_totals(dice2, faces2);
    double wins = 0;
    for (const auto& p1 : totals1) {
        for (const auto& p2 : totals2) {
            if (p2.first >= p1.first)
                break;
            wins += p1.second * p2.second;
        }
    }
    double total = std::pow(faces1, dice1) * std::pow(faces2, dice2);
    return wins/total;
}

int main() {
    std::cout << std::setprecision(10);
    std::cout << probability(9, 4, 6, 6) << '\n';
    std::cout << probability(5, 10, 6, 7) << '\n';
    return 0;
}


def do_until(condition; next):
  def u: if condition then . else (next|u) end;
  u;

def mdroot(n):
  def multiply: reduce .[] as $i (1; .*$i);
  # state: [mdr, persist]
  [n, 0]
  | do_until( .[0] < 10;
              [(.[0] | tostring | explode | map(.-48) | multiply), .[1] + 1]
            );

# Produce a table with 10 rows (numbered from 0),
# showing the first n numbers having the row-number as the mdr
def tabulate(n):
  # state: [answer_matrix, next_i]
  def tab:
    def minlength: map(length) | min;
    .[0] as $matrix
    | .[1] as $i
    | if (.[0]|minlength) == n then .[0]
      else (mdroot($i) | .[0]) as $mdr
      | if $matrix[$mdr]|length < n then
          ($matrix[$mdr] + [$i]) as $row
          | $matrix | setpath([$mdr]; $row)
        else $matrix
        end
      | [ ., $i + 1 ]
      | tab
      end;

  [[], 0]  | tab;


function digitalmultroot{S<:Integer,T<:Integer}(n::S, bs::T=10)
    -1 < n && 1 < bs || throw(DomainError())
    ds = n
    pers = 0
    while bs <= ds
        ds = prod(digits(ds, bs))
        pers += 1
    end
    return (pers, ds)
end


// version 1.1.2

fun multDigitalRoot(n: Int): Pair<Int, Int> = when {
        n < 0   -> throw IllegalArgumentException("Negative numbers not allowed")
        else    -> {
            var mdr: Int
            var mp = 0
            var nn = n
            do {
                mdr = if (nn > 0) 1 else 0
                while (nn > 0) {
                    mdr *= nn % 10
                    nn /= 10
                }
                mp++
                nn = mdr
            }
            while (mdr >= 10)
            Pair(mdr, mp)
        }
    }

fun main(args: Array<String>) {
    val ia = intArrayOf(123321, 7739, 893, 899998)
    for (i in ia) {
        val (mdr, mp) = multDigitalRoot(i)
        println("${i.toString().padEnd(9)} MDR = $mdr  MP = $mp")
    }
    println()
    println("MDR   n0    n1    n2    n3    n4")
    println("===  ===========================")
    val ia2 = Array(10) { IntArray(6) } // all zero by default
    var n = 0
    var count = 0
    do {
        val (mdr, _) = multDigitalRoot(n)
        if (ia2[mdr][0] < 5) {
            ia2[mdr][0]++
            ia2[mdr][ia2[mdr][0]] = n
            count++
        }
        n++
    }
    while (count < 50)

    for (i in 0..9) {
        print("$i:")
        for (j in 1..5) print("%6d".format(ia2[i][j]))
        println()
    }
}


import std.stdio, std.range, std.algorithm;

void throwDie(in uint nSides, in uint nDice, in uint s, uint[] counts)
pure nothrow @safe @nogc {
    if (nDice == 0) {
        counts[s]++;
        return;
    }

    foreach (immutable i; 1 .. nSides + 1)
        throwDie(nSides, nDice - 1, s + i, counts);
}

real beatingProbability(uint nSides1, uint nDice1,
                        uint nSides2, uint nDice2)()
pure nothrow @safe /*@nogc*/ {
    uint[(nSides1 + 1) * nDice1] C1;
    throwDie(nSides1, nDice1, 0, C1);

    uint[(nSides2 + 1) * nDice2] C2;
    throwDie(nSides2, nDice2, 0, C2);

    immutable p12 = real((ulong(nSides1) ^^ nDice1) *
                         (ulong(nSides2) ^^ nDice2));

    return cartesianProduct(C1[].enumerate, C2[].enumerate)
           .filter!(p => p[0][0] > p[1][0])
           .map!(p => real(p[0][1]) * p[1][1] / p12)
           .sum;
}

void main() @safe {
    writefln("%1.16f", beatingProbability!(4, 9, 6, 6));
    writefln("%1.16f", beatingProbability!(10, 5, 7, 6));
}


multDigitalRoot=lambda (n as decimal) ->{
	if n<0 then error "Negative numbers not allowed"
	def decimal mdr, mp, nn
	nn=n
	do
		mdr=IF(nn>0->[email protected], [email protected])
		while nn>0
			mdr*=nn mod [email protected]
			nn|div [email protected]
		end while
		mp++
		nn=mdr
	when mdr>=10
	=(mdr, mp)
}
Document doc$
ia=(123321, 7739, 893, 899998)
in_ia=each(ia)
while in_ia
	(mdr, mp)=multDigitalRoot(array(in_ia))
	doc$=format$("{0::-9} mdr = {1} MP = {2}", array(in_ia), mdr, mp)+{
	}
end while
let [email protected], count=0&
dim ia2(0 to 9, 0 to 5)
do
	mdr=multDigitalRoot(n)#val(0)
	if ia2(mdr, 0)<5 then
		ia2(mdr, 0)++
		ia2(mdr, ia2(mdr, 0))=n
		count++
	end if
	n++
when count<50

doc$={MDR    n0    n1    n2    n3    n4
}
doc$={===  ============================
}
for i=0 to 9
	doc$=format$("{0}: ", i)
	for j=1 to 5
		doc$=format$("{0::-6}", ia2(i, j))
	next
	doc$={
	}
next
Clipboard doc$
// Print like in a file (-2 is for console):
Print #-2, doc$


ClearAll[mdr, mp, nums];
mdr[n_] := NestWhile[Times @@ IntegerDigits[#] &, n, # > 9 &];
mp[n_] := [email protected][Times @@ IntegerDigits[#] &, n, # > 9 &] - 1;
TableForm[{#, mdr[#], mp[#]} & /@ {123321, 7739, 893, 899998},
  TableHeadings -> {None, {"Number", "MDR", "MP"}}]
nums = ConstantArray[{}, 10];
For[i = 0, Min[Length /@ nums] < 5, i++,  AppendTo[nums[[mdr[i] + 1]], i]];
TableForm[Table[{i, Take[nums[[i + 1]], 5]}, {i, 0, 9}],
  TableHeadings -> {None, {"MDR", "First 5"}}, TableDepth -> 2]


USING: dice generalizations kernel math prettyprint sequences ;
IN: rosetta-code.dice-probabilities

: winning-prob ( a b c d -- p )
    [ [ random-roll ] [email protected] > ] 4 ncurry [ 100000 ] dip replicate
    [ [ t = ] count ] [ length ] bi /f ;

9 4 6 6 winning-prob
5 10 6 7 winning-prob [ . ] [email protected]


' Gambas module file

Public Sub Main()
Dim iSides, iPlayer1, iPlayer2, iTotal1, iTotal2, iCount, iCount0 As Integer
Dim iDice1 As Integer = 9
Dim iDice2 As Integer = 6
Dim iSides1 As Integer = 4
Dim iSides2 As Integer = 6

Randomize

For iCount0 = 0 To 1
  For iCount = 1 To 100000
    iPlayer1 = Roll(iDice1, iSides1)
    iPlayer2 = Roll(iDice2, iSides2)
    If iPlayer1 > iPlayer2 Then
      iTotal1 += 1
    Else If iPlayer1 <> iPlayer2 Then
      iTotal2 += 1
    Endif
  Next

  Print "Tested " & Str(iCount - 1) & " times"
  Print "Player1 with " & Str(iDice1) & " dice of " & Str(iSides1) & " sides"
  Print "Player2 with " & Str(iDice2) & " dice of " & Str(iSides2) & " sides"
  Print "Total wins Player1 = " & Str(iTotal1) & " - " & Str(iTotal2 / iTotal1)
  Print "Total wins Player2 = " & Str(iTotal2)
  Print Str((iCount - 1) - (iTotal1 + iTotal2)) & " draws" & gb.NewLine

  iDice1 = 5
  iDice2 = 6
  iSides1 = 10
  iSides2 = 7
  iTotal1 = 0
  iTotal2 = 0
Next

End

Public Sub Roll(iDice As Integer, iSides As Integer) As Integer
Dim iCount, iTotal As Short

For iCount = 1 To iDice
  iTotal += Rand(1, iSides)
Next

Return iTotal

End


import strutils, sequtils, sugar

proc mdroot(n: int): tuple[mp, mdr: int] =
  var mdr = @[n]
  while mdr[mdr.high] > 9:
    var n = 1
    for dig in $mdr[mdr.high]:
      n *= parseInt($dig)
    mdr.add n
  (mdr.high, mdr[mdr.high])

for n in [123321, 7739, 893, 899998]:
  echo align($n, 6)," ",mdroot(n)
echo ""

var table = newSeqWith(10, newSeq[int]())
for n in 0..int.high:
  if table.map((x: seq[int]) => x.len).min >= 5: break
  table[mdroot(n).mdr].add n

for mp, val in table:
  echo mp, ": ", val[0..4]


package main

import(
    "math"
    "fmt"
)

func minOf(x, y uint) uint {
    if x < y {
        return x
    }
    return y
}

func throwDie(nSides, nDice, s uint, counts []uint) {
    if nDice == 0 {
        counts[s]++
        return
    }
    for i := uint(1); i <= nSides; i++ {
        throwDie(nSides, nDice - 1, s + i, counts)
    }
}

func beatingProbability(nSides1, nDice1, nSides2, nDice2 uint) float64 {
    len1 := (nSides1 + 1) * nDice1
    c1 := make([]uint, len1)  // all elements zero by default
    throwDie(nSides1, nDice1, 0, c1)

    len2 := (nSides2 + 1) * nDice2
    c2 := make([]uint, len2)
    throwDie(nSides2, nDice2, 0, c2)
    p12 := math.Pow(float64(nSides1), float64(nDice1)) *
           math.Pow(float64(nSides2), float64(nDice2))

    tot := 0.0
    for i := uint(0); i < len1; i++ {
        for j := uint(0); j < minOf(i, len2); j++ {
            tot += float64(c1[i] * c2[j]) / p12
        }
    }
    return tot
}

func main() {
    fmt.Println(beatingProbability(4, 9, 6, 6))
    fmt.Println(beatingProbability(10, 5, 7, 6))
}


program MultRoot;
{$IFDEF FPC}
  {$MODE DELPHI}{$OPTIMIZATION ON,ALL}{$CODEALIGN proc=16}
{$ENDIF}
{$IFDEF WINDOWS}
  {$APPTYPE CONSOLE}
{$ENDIF}
uses
  sysutils;
type
  tMul3Dgt = array[0..999] of Uint32;
  tMulRoot = record
               mrNum,
               mrMul,
               mrPers : Uint64;
             end;
const
  Testnumbers : array[0..16] of Uint64 =(123321,7739,893,899998,
                                        18446743999999999999,
    //first occurence of persistence 0..11
                                    0,10,25,39,77,679, 6788, 68889, 2677889,
                                        26888999, 3778888999, 277777788888899);

var
  Mul3Dgt : tMul3Dgt;

procedure InitMulDgt;
var
  i,j,k,l : Int32;
begin
  l := 999;
  For i := 9 downto 0 do
    For j := 9 downto 0 do
      For k := 9 downto 0 do
      Begin
        Mul3Dgt[l] := i*j*k;
        dec(l);
      end;
end;

function GetMulDigits(n:Uint64):UInt64;inline;
var
  pMul3Dgt :^tMul3Dgt;
  q :Uint64;
begin
  pMul3Dgt := @Mul3Dgt[0];
  result := 1;
  while n >= 1000 do
  begin
    q := n div 1000;
    result *= pMul3Dgt^[n-1000*q];
    n := q;
  end;
  If n>=100 then
    result *= pMul3Dgt^[n]
  else
    if n>=10 then
       result *= pMul3Dgt^[n+100]
    else
      result *= n;//Mul3Dgt[n+110]
end;

procedure GetMulRoot(var MulRoot:tMulRoot);
var
  mr,
  pers : UInt64;
Begin
  pers := 0;
  mr := MulRoot.mrNum;
  while mr >=10 do
  Begin
    mr := GetMulDigits(mr);
    inc(pers);
  end;
  MulRoot.mrMul:= mr;
  MulRoot.mrPers:= pers;
end;

const
  MaxDgtCount = 9;
var
  //all initiated with 0
  MulRoot:tMulRoot;
  Sol    : array[0..9,0..MaxDgtCount-1] of tMulRoot;
  SolIds : array[0..9] of Int32;
  i,idx,mr,AlreadyDone : Int32;

BEGIN
  InitMulDgt;

  AlreadyDone := 10;//0..9
  MulRoot.mrNum := 0;
  repeat
    GetMulRoot(MulRoot);
    mr := MulRoot.mrMul;
    idx := SolIds[mr];
    If idx<MaxDgtCount then
    begin
      Sol[mr,idx]:= MulRoot;
      inc(idx);
      SolIds[mr]:= idx;
      if idx =MaxDgtCount then
        dec(AlreadyDone);
    end;
    inc(MulRoot.mrNum);
  until AlreadyDone = 0;
  writeln('MDR: First');
  For i := 0 to 9 do
  begin
    write(i:3,':');
    For idx := 0 to MaxDgtCount-1 do
      write(Sol[i,idx].mrNum:MaxDgtCount+1);
    writeln;
  end;
  writeln;
  writeln('number':20,' mulroot   persitance');
  For i := 0 to High(Testnumbers) do
  begin
    MulRoot.mrNum := Testnumbers[i];
    GetMulRoot(MulRoot);
    With MulRoot do
      writeln(mrNum:20,mrMul:8,mrPers:8);
  end;
  {$IFDEF WINDOWS}
  readln;
  {$ENDIF}
END.


import Control.Monad (replicateM)
import Data.List (group, sort)

succeeds :: (Int, Int) -> (Int, Int) -> Double
succeeds p1 p2 =
  sum
    [ realToFrac (c1 * c2) / totalOutcomes
    | (s1, c1) <- countSums p1
    , (s2, c2) <- countSums p2
    , s1 > s2 ]
  where
    totalOutcomes = realToFrac $ uncurry (^) p1 * uncurry (^) p2
    countSums (nFaces, nDice) = f [1 .. nFaces]
      where
        f =
          fmap (((,) . head) <*> (pred . length)) .
          group . sort . fmap sum . replicateM nDice

main :: IO ()
main = do
  print $ (4, 9) `succeeds` (6, 6)
  print $ (10, 5) `succeeds` (7, 6)


import java.util.Random;

public class Dice{
	private static int roll(int nDice, int nSides){
		int sum = 0;
		Random rand = new Random();
		for(int i = 0; i < nDice; i++){
			sum += rand.nextInt(nSides) + 1;
		}
		return sum;
	}

	private static int diceGame(int p1Dice, int p1Sides, int p2Dice, int p2Sides, int rolls){
		int p1Wins = 0;
		for(int i = 0; i < rolls; i++){
			int p1Roll = roll(p1Dice, p1Sides);
			int p2Roll = roll(p2Dice, p2Sides);
			if(p1Roll > p2Roll) p1Wins++;
		}
		return p1Wins;
	}

	public static void main(String[] args){
		int p1Dice = 9; int p1Sides = 4;
		int p2Dice = 6; int p2Sides = 6;
		int rolls = 10000;
		int p1Wins = diceGame(p1Dice, p1Sides, p2Dice, p2Sides, rolls);
		System.out.println(rolls + " rolls, p1 = " + p1Dice + "d" + p1Sides + ", p2 = " + p2Dice + "d" + p2Sides);
		System.out.println("p1 wins " + (100.0 * p1Wins / rolls) + "% of the time");

		System.out.println();

		p1Dice = 5; p1Sides = 10;
		p2Dice = 6; p2Sides = 7;
		rolls = 10000;
		p1Wins = diceGame(p1Dice, p1Sides, p2Dice, p2Sides, rolls);
		System.out.println(rolls + " rolls, p1 = " + p1Dice + "d" + p1Sides + ", p2 = " + p2Dice + "d" + p2Sides);
		System.out.println("p1 wins " + (100.0 * p1Wins / rolls) + "% of the time");

		System.out.println();

		p1Dice = 9; p1Sides = 4;
		p2Dice = 6; p2Sides = 6;
		rolls = 1000000;
		p1Wins = diceGame(p1Dice, p1Sides, p2Dice, p2Sides, rolls);
		System.out.println(rolls + " rolls, p1 = " + p1Dice + "d" + p1Sides + ", p2 = " + p2Dice + "d" + p2Sides);
		System.out.println("p1 wins " + (100.0 * p1Wins / rolls) + "% of the time");

		System.out.println();

		p1Dice = 5; p1Sides = 10;
		p2Dice = 6; p2Sides = 7;
		rolls = 1000000;
		p1Wins = diceGame(p1Dice, p1Sides, p2Dice, p2Sides, rolls);
		System.out.println(rolls + " rolls, p1 = " + p1Dice + "d" + p1Sides + ", p2 = " + p2Dice + "d" + p2Sides);
		System.out.println("p1 wins " + (100.0 * p1Wins / rolls) + "% of the time");
	}
}


(de mdr-mp (N)
   "Returns the solutions in a list, i.e., '(MDR MP)"
   (let MP 0
      (while (< 1 (length N))
         (setq N (apply * (mapcar format (chop N))))
         (inc 'MP) )
      (list N MP) ) )

# Get the MDR/MP of these nums.
(setq Test-nums '(123321 7739 893 899998))

(let Fmt (6 5 5)
   (tab Fmt "Values" "MDR" "MP")
   (tab Fmt "======" "===" "==")
   (for I Test-nums
      (let MDR-MP (mdr-mp I)
         (tab Fmt I (car MDR-MP) (cadr MDR-MP)) ) ) )

(prinl)

# Get the nums of these MDRs.
(setq *Want 5)

(setq *Solutions (make (for MDR (range 0 9)
   (link (make (let N 0 (until (= *Want (length (made)))
      (when (= MDR (car (mdr-mp N)))
         (link N) )
      (inc 'N) )))) )))

(let Fmt (3 1 -1)
   (tab Fmt "MDR" ":  " "Values")
   (tab Fmt "===" "   " "======")
   (for (I . S) *Solutions
      (tab Fmt (dec I) ":  " (glue ", " S)) ) )


with javascript_semantics
function mdr_mp(integer m)
    integer mp = 0
    while m>9 do
        integer newm = 1
        while m do
            newm *= remainder(m,10)
            m = floor(m/10)
        end while
        m = newm
        mp += 1
    end while
    return {m,mp}
end function

constant tests = {123321, 7739, 893, 899998}
printf(1,"Number     MDR     MP\n")
printf(1,"======     ===     ==\n")
for i=1 to length(tests) do
    integer ti = tests[i]
    printf(1,"%6d %6d %6d\n",ti&mdr_mp(ti))
end for

integer i=0, found = 0
sequence res = columnize({tagset(9,0)})
               -- (ie {{0},{1},..,{9}})
while found<50 do -- (ie the full 10*5)
    integer mdr1 = mdr_mp(i)[1]+1
    sequence m1 = res[mdr1]
    if length(m1)<6 then
        res[mdr1] = 0 -- (avoid p2js violation)
        m1 &= i
        res[mdr1] = m1
        found += 1
    end if
    i += 1
end while

printf(1,"\nMDR    1     2     3     4     5")
printf(1,"\n===  ===========================\n")

for i=1 to 10 do
    printf(1,"%2d %5d %5d %5d %5d %5d\n",res[i])
end for


let Player = function(dice, faces) {
  this.dice = dice;
  this.faces = faces;
  this.roll = function() {
    let results = [];
    for (let x = 0; x < dice; x++)
      results.push(Math.floor(Math.random() * faces +1));
    return eval(results.join('+'));
  }
}

function contest(player1, player2, rounds) {
  let res = [0, 0, 0];
  for (let x = 1; x <= rounds; x++) {
    let a = player1.roll(),
        b = player2.roll();
    switch (true) {
      case (a > b): res[0]++; break;
      case (a < b): res[1]++; break;
      case (a == b): res[2]++; break;
    }
  }
  document.write(`

        Player 1 (${player1.dice} × d${player1.faces}): ${res[0]} wins

        Player 2 (${player2.dice} × d${player2.faces}): ${res[1]} wins

        Draws: ${res[2]}

        Chances for Player 1 to win:
        ~${Math.round(res[0] / eval(res.join('+')) * 100)} %

  `);
}

let p1, p2;

p1 = new Player(9, 4),
p2 = new Player(6, 6);
contest(p1, p2, 1e6);

p1 = new Player(5, 10);
p2 = new Player(6, 7);
contest(p1, p2, 1e6);


multiple: procedure options (main);  /* 29 April 2014 */

   declare n fixed binary (31);

find_mdr: procedure;
   declare (mdr, mp, p) fixed binary (31);

   mdr = n;
   do mp = 1 by 1 until (p <= 9);
      p = 1;
      do until (mdr = 0); /* Form product of the digits in mdr. */
         p = mod(mdr, 10) * p;
         mdr= mdr/10;
      end;
      mdr = p;
   end;
   put skip data (n, mdr, mp);
end find_mdr;

   do n = 123321, 7739, 893, 899998;
      call find_mdr;
   end;

end multiple;


try:
    from functools import reduce
except:
    pass

def mdroot(n):
    'Multiplicative digital root'
    mdr = [n]
    while mdr[-1] > 9:
        mdr.append(reduce(int.__mul__, (int(dig) for dig in str(mdr[-1])), 1))
    return len(mdr) - 1, mdr[-1]

if __name__ == '__main__':
    print('Number: (MP, MDR)\n======  =========')
    for n in (123321, 7739, 893, 899998):
        print('%6i: %r' % (n, mdroot(n)))

    table, n = {i: [] for i in range(10)}, 0
    while min(len(row) for row in table.values()) < 5:
        mpersistence, mdr = mdroot(n)
        table[mdr].append(n)
        n += 1
    print('\nMP: [n0..n4]\n==  ========')
    for mp, val in sorted(table.items()):
        print('%2i: %r' % (mp, val[:5]))


# To take advantage of gojq's arbitrary-precision integer arithmetic:
def power($b): . as $in | reduce range(0;$b) as $i (1; . * $in);

# Input: an array (aka: counts)
def throwDie($nSides; $nDice; $s):
  if $nDice == 0
  then .[$s] +=  1
  else reduce range(1; $nSides + 1) as $i (.;
    throwDie($nSides; $nDice-1; $s + $i) )
  end ;

def beatingProbability(nSides1; nDice1; nSides2; nDice2):
  def a: [range(0; .) | 0];

  ((nSides1 + 1) * nDice1) as $len1
  | ($len1 | a | throwDie(nSides1; nDice1; 0)) as $c1

  | ((nSides2 + 1) * nDice2) as $len2
  | ($len2 | a | throwDie(nSides2; nDice2; 0)) as $c2

  |((nSides1|power(nDice1)) * (nSides2|power(nDice2))) as $p12

  | reduce range(0; $len1) as $i (0;
      reduce range(0; [$i, $len2] | min) as $j (.;
          . + ($c1[$i] * $c2[$j] / $p12) ) ) ;

beatingProbability(4; 9; 6; 6),
beatingProbability(10; 5; 7; 6)


play(ndices::Integer, nfaces::Integer) = (nfaces, ndices) ∋ 0 ? 0 : sum(rand(1:nfaces) for i in 1:ndices)

simulate(d1::Integer, f1::Integer, d2::Integer, f2::Integer; nrep::Integer=1_000_000) =
    mean(play(d1, f1) > play(d2, f2) for _ in 1:nrep)

println("\nPlayer 1: 9 dices, 4 faces\nPlayer 2: 6 dices, 6 faces\nP(Player1 wins) = ", simulate(9, 4, 6, 6))
println("\nPlayer 1: 5 dices, 10 faces\nPlayer 2: 6 dices, 7 faces\nP(Player1 wins) = ", simulate(5, 10, 6, 7))


// version 1.1.2

fun throwDie(nSides: Int, nDice: Int, s: Int, counts: IntArray) {
    if (nDice == 0) {
        counts[s]++
        return
    }
    for (i in 1..nSides) throwDie(nSides, nDice - 1, s + i, counts)
}

fun beatingProbability(nSides1: Int, nDice1: Int, nSides2: Int, nDice2: Int): Double {
    val len1 = (nSides1 + 1) * nDice1
    val c1 = IntArray(len1)  // all elements zero by default
    throwDie(nSides1, nDice1, 0, c1)

    val len2 = (nSides2 + 1) * nDice2
    val c2 = IntArray(len2)
    throwDie(nSides2, nDice2, 0, c2)

    val p12 = Math.pow(nSides1.toDouble(), nDice1.toDouble()) *
              Math.pow(nSides2.toDouble(), nDice2.toDouble())

    var tot = 0.0
    for (i in 0 until len1) {
        for (j in 0 until minOf(i, len2)) {
            tot += c1[i] * c2[j] / p12
        }
    }
    return tot
}

fun main(args: Array<String>) {
    println(beatingProbability(4, 9, 6, 6))
    println(beatingProbability(10, 5, 7, 6))
}


  [ abs 1 swap
    [ base share /mod
      rot * swap
      dup 0 = until ]
    drop ]                       is digitproduct ( n --> n   )

  [ 0 swap
    [ dup base share > while
      dip 1+
      digitproduct again ] ]     is mdr          ( n --> n n )

  [ dup mdr
    rot echo
    say ": "
    swap echo
    say ", "
    echo cr ]                    is task.1       ( n -->     )

  [ times
      [ i^ [] swap dup rot
        [ unrot dup mdr nip
          swap dip
            [ over = ]
          swap iff
            [ rot over join ]
          else rot
          dip 1+
          dup size 5 = until ]
        i^ echo say " : "
        echo cr 2drop ] ]       is task.2        ( n -->     )

  ' [ 123321 7739 893 899998 ] witheach task.1
  cr
  10 task.2


#lang racket
(define (digital-product n)
  (define (inr-d-p m rv)
    (cond
      [(zero? m) rv]
      [else (define-values (q r) (quotient/remainder m 10))
            (if (zero? r) 0 (inr-d-p q (* rv r)))])) ; lazy on zero
  (inr-d-p n 1))

(define (mdr/mp n)
  (define (inr-mdr/mp m i)
    (if (< m 10) (values m i) (inr-mdr/mp (digital-product m) (add1 i))))
  (inr-mdr/mp n 0))

(printf "Number\tMDR\tmp~%======\t===\t==~%")
(for ((n (in-list '(123321 7739 893 899998))))
  (define-values (mdr mp) (mdr/mp n))
  (printf "~a\t~a\t~a~%" n mdr mp))

(printf "~%MDR\t[n0..n4]~%===\t========~%")
(for ((MDR (in-range 10)))
  (define (has-mdr? n) (define-values (mdr mp) (mdr/mp n)) (= mdr MDR))
  (printf "~a\t~a~%" MDR (for/list ((_ 5) (n (sequence-filter has-mdr? (in-naturals)))) n)))


sub multiplicative-digital-root(Int $n) {
    return .elems - 1, .[.end]
        given cache($n, {[*] .comb} ... *.chars == 1)
}

for 123321, 7739, 893, 899998 {
    say "$_: ", .&multiplicative-digital-root;
}

for ^10 -> $d {
    say "$d : ", .[^5]
        given (1..*).grep: *.&multiplicative-digital-root[1] == $d;
}


local function simu(ndice1, nsides1, ndice2, nsides2)
  local function roll(ndice, nsides)
    local result = 0;
    for i = 1, ndice do
      result = result + math.random(nsides)
    end
    return result
  end
  local wins, coms = 0, 1000000
  for i = 1, coms do
    local roll1 = roll(ndice1, nsides1)
    local roll2 = roll(ndice2, nsides2)
    if (roll1 > roll2) then
      wins = wins + 1
    end
  end
  print("simulated:  p1 = "..ndice1.."d"..nsides1..", p2 = "..ndice2.."d"..nsides2..",  prob = "..wins.." / "..coms.." = "..(wins/coms))
end

simu(9, 4, 6, 6)
simu(5, 10, 6, 7)


ClearAll[GetProbability]
GetProbability[{dice1_List, n_Integer}, {dice2_List, m_Integer}] :=
 Module[{a, b, lena, lenb},
  a = Tuples[dice1, n];
  a = Plus @@@ a;
  lena = a // Length;
  a = Tally[a];
  a[[All, 2]] /= lena;

  b = Tuples[dice2, m];
  b = Plus @@@ b;
  lenb = b // Length;
  b = Tally[b];
  b[[All, 2]] /= lenb;

  Total[If[#[[1, 1]] > #[[2, 1]], #[[1, 2]] #[[2, 2]], 0] & /@
    Tuples[{a, b}]]
  ]
GetProbability[{Range[4], 9}, {Range[6], 6}]
GetProbability[{Range[10], 5}, {Range[7], 6}]


Red ["Multiplicative digital root"]

mdr: function [
    "Returns a block containing the mdr and persistence of an integer"
    n [integer!]
][
    persistence: 0
    while [n > 10][
        product: 1
        m: n
        while [m > 0][
            product: m % 10 * product
            m: to-integer m / 10
        ]
        persistence: persistence + 1
        n: product
    ]
    reduce [n persistence]
]

foreach n [123321 7739 893 899998][
    result: mdr n
    print [pad n 6 "has multiplicative persistence" result/2 "and MDR" result/1]
]

print [newline "First five numbers with MDR of"]

repeat i 10 [
    prin rejoin [i - 1 ": "]
    hits: n: 0
    while [hits < 5][
        if i - 1 = first mdr n [
            prin pad n 5
            hits: hits + 1
        ]
        n: n + 1
    ]
    prin newline
]


/*REXX program finds the  persistence and multiplicative  digital root  of some numbers.*/
numeric digits 100                               /*increase the number of decimal digits*/
parse arg x                                      /*obtain optional arguments from the CL*/
if x='' | x=","  then x=123321 7739 893 899998   /*Not specified?  Then use the default.*/
say center('number', 8)      ' persistence   multiplicative digital root'
say copies('─'     , 8)      ' ───────────   ───────────────────────────'
                                                 /* [↑]  the title  and  separator.     */
     do j=1  for words(x);        n=word(x, j)   /*process each number in the   X  list.*/
     parse value  MDR(n)   with   mp mdr         /*obtain the persistence and the  MDR. */
     say right(n,8) center(mp,13) center(mdr,30) /*display a number,  persistence,  MDR.*/
     end   /*j*/                                 /* [↑]  show MP & MDR for each number. */
say copies('─'     , 8)      ' ───────────   ───────────────────────────'
say; say;                target=5
say 'MDR        first '  target  " numbers that have a matching MDR"
say '═══   ═══════════════════════════════════════════════════'

     do k=0  for 10; hits=0;   _=                /*show numbers that have an MDR of  K. */
       do m=k  until hits==target                /*find target numbers with an MDR of K.*/
       if word( MDR(m), 2)\==k  then iterate     /*is this the  MDR  that's wanted?     */
       hits=hits + 1;       _=space(_ m',')      /*yes, we got a hit,  add to the list. */
       end   /*m*/                               /* [↑]  built a list of MDRs that = K. */
     say " "k':     ['strip(_, , ',')"]"         /*display the  K  (MDR)  and the list. */
     end     /*k*/                               /* [↑]  done with the   K   MDR list.  */
say '═══   ═══════════════════════════════════════════════════'
exit 0                                           /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
MDR: procedure; parse arg y; y=abs(y)            /*get the number and determine the MDR.*/
                   do p=1      until  y<10;    parse var  y  r  2
                       do k=2  to length(y);   r=r * substr(y, k, 1)
                       end   /*k*/
                   y=r
                   end       /*p*/               /* [↑]  wash, rinse, and repeat ···    */
                return p r                       /*return the persistence and the  MDR. */


import bignum
from math import sum

proc counts(ndices, nsides: int): seq[int] =
  result.setlen(ndices * nsides + 1)
  for i in 1..nsides:
    result[i] = 1
  for i in 1..<ndices:
    var c = newSeq[int](result.len)
    for sum in i..(i * nsides):
      for val in 1..nsides:
        inc c[sum + val], result[sum]
    result.shallowCopy(c)

proc probabilities(counts: seq[int]): seq[Rat] =
  result.setLen(counts.len)
  let total = sum(counts)
  for i, n in counts:
    result[i] = newRat(n, total)

proc beatingProbability(ndices1, nsides1, ndices2, nsides2: int): Rat =
  let counts1 = counts(ndices1, nsides1)
  let counts2 = counts(ndices2, nsides2)
  var p1 = counts1.probabilities()
  var p2 = counts2.probabilities()

  result = newRat(0)
  for sum1 in ndices1..p1.high:
    var p = newRat(0)
    for sum2 in ndices2..min(sum1 - 1, p2.high):
      p += p2[sum2]
    result += p1[sum1] * p

echo beatingProbability(9, 4, 6, 6).toFloat
echo beatingProbability(5, 10, 6, 7).toFloat


Numeric Digits 30
Call test '9 4 6 6'
Call test '5 10 6 7'
Exit
test:
Parse Arg w1 s1 w2 s2
p1.=0
p2.=0
Call pp 1,w1,s1,p1.,p2.
Call pp 2,w2,s2,p1.,p2.
p2low.=0
Do x=w1 To w1*s1
  Do y=0 To x-1
    p2low.x+=p2.y
    End
  End
pwin1=0
Do x=w1 To w1*s1
  pwin1+=p1.x*p2low.x
  End
Say 'Player 1 has' w1 'dice with' s1 'sides each'
Say 'Player 2 has' w2 'dice with' s2 'sides each'
Say 'Probability for player 1 to win:' pwin1
Say ''
Return

pp: Procedure
/*---------------------------------------------------------------------
* Compute and assign probabilities to get a sum x
* when throwing w dice each having s sides (marked from 1 to s)
* k=1 sets p1.*, k=2 sets p2.*
*--------------------------------------------------------------------*/
Use Arg k,w,s,p1.,p2.
str=''
cnt.=0
Do wi=1 To w
  str=str||'Do v'wi'=1 To' s';'
  End
str=str||'sum='
Do wi=1 To w-1
  str=str||'v'wi'+'
  End
str=str||'v'w';'
str=str||'cnt.'sum'+=1;'
Do wi=1 To w
  str=str||'End;'
  End
Interpret str
psum=0
Do x=0 To w*s
  If k=1 Then
    p1.x=cnt.x/(s**w)
  Else
    p2.x=cnt.x/(s**w)
  psum+=p1.x
  End
Return


# Project : Digital root/Multiplicative digital root

load "stdlib.ring"
root = newlist(10, 5)
for r = 1 to 10
     for x = 1 to 5
          root[r][x] = 0
     next
next
root2 = list(10)
for y = 1 to 10
     root2[y] = 0
next
see "Number  MDR   MP" + nl
num = [123321, 7739, 893, 899998]
digroot(num)
see nl
num = 0:12000
digroot(num)
see "First five numbers with MDR in first column:" + nl
for n1 = 1 to 10
     see "" + (n1-1) + " => "
     for n2 = 1 to 5
         see "" + root[n1][n2] + "  "
     next
     see nl
next

func digroot(num)
        for n = 1 to len(num)
            sum = 0
            numold = num[n]
            while true
                    pro = 1
                    strnum = string(numold)
                    for nr = 1 to len(strnum)
                        pro = pro * number(strnum[nr])
                    next
                    sum = sum + 1
                    numold = pro
                    numn = string(num[n])
                    sp = 6 - len(string(num[n]))
                    if sp > 0
                       for p = 1 to sp + 2
                           numn = " " + numn
                       next
                    ok
                    if len(string(numold)) = 1 and len(num) < 5
                       see "" + numn + "     " + numold + "       " + sum + nl
                       exit
                    ok
                    if len(string(numold)) = 1 and len(num) > 4
                       root2[numold+1] = root2[numold+1] + 1
                       if root2[numold+1] < 6
                          root[numold+1][root2[numold+1]] = num[n]
                       ok
                       exit
                    ok
              end
        next


def mdroot(n)
  mdr, persist = n, 0
  until mdr < 10 do
    mdr = mdr.digits.inject(:*)
    persist += 1
  end
  [mdr, persist]
end

puts "Number: MDR  MP", "======  ===  =="
[123321, 7739, 893, 899998].each{|n| puts "%6d:   %d  %2d" % [n, *mdroot(n)]}

counter = Hash.new{|h,k| h[k]=[]}
0.step do |i|
  counter[mdroot(i).first] << i
  break if counter.values.all?{|v| v.size >= 5 }
end
puts "", "MDR: [n0..n4]", "===  ========"
10.times{|i| puts "%3d: %p" % [i, counter[i].first(5)]}


		;; On the 44th day of Discord in the YOLD 3186, ddate
		;; has finally come to CP/M.
bdos:		equ	5	; CP/M syscalls
puts:		equ	9
putch:		equ	2
fcb:		equ	5ch
month:		equ	fcb + 1		; use the FCB as the date argument
day:		equ	month + 2
year:		equ	day + 2
		org	100h
		;; CP/M will try to parse the command line arguments as if
		;; they are filenames. As luck would have it, MMDDYYYY is
		;; 8 characters. It would be a shame not to use this.
		lxi	h,month		; check that the 'filename' is
		lxi	b,0800h		; all digits (and zero out C)
argcheck:	mov	a,m
		call	isdigit
		jnc	argerror	; if not, give an error and exit
		inx	h
		dcr	b
		jnz	argcheck
		;; Fix the year (add 1166 to it, digit by digit)
		lxi	d,year + 3
		lxi	h,yearoffset + 3
		mvi	b,4
		ana	a		; Clear carry
yeardgt:	ldax	d		; Get digit
		adc	m		; Add offset digit
		cpi	'9' + 1		; Did we overshoot?
		cmc			; Carry is opposite of what we need
		jnc	yearnextdgt	; No carry = no adjustment
		sui	10		; Compensate
		stc			; Carry the one
yearnextdgt:	stax	d		; Save digit
		dcx	d		; Look at more significant digit
		dcx	h
		dcr	b		; Until we're out of digits
		jnz	yeardgt
		lxi	h,year + 4	; Terminate the year with a $
		mvi	m,'$'		; for easy output.
		;; Is it St. Tib's Day?
		lxi	d,month		; Check month and day
		lxi	h,leap		; Against '0229'
		mvi	b,4
tibcheck:	ldax	d		; Get date byte
		cmp	m		; Match against leap day
		jnz	notibs		; No match = not Tibs
		inx	h
		inx	d
		dcr 	b
		jnz	tibcheck	; if they all match it _is_ Tibs
		;; Print "St. Tib's Day in the YOLD NNNN."
		lxi	d,tibsday
		call	outs		; fall through into printyear
		;; Print " in the YOLD NNNN."
printyear:	lxi	d,yold
		call	outs
		lxi	d,year
		jmp	outs		; if Tibs, this ends the program
		;; It isn't St. Tib's Day. We'll need to do real work :(
notibs:		lxi	h,month		; Find days at beginning of month
		call	parsenum	; (not counting Tibs)
		dcr	a		; subtract one (table is 0-indexed)
		cpi	12		; check that month < 12
		jnc	argerror	; otherwise, argument error
		ana	a		; multiply month by 2
		ral			; (entries are 2 bytes wide)
		lxi	h,monthdays	; get days table
		mov	d,c		; look up the entry (C is zero here)
		mov	e,a
		dad	d
		mov	e,m		; load the 16-bit entry into DE
		inx	h
		mov	d,m
		lxi	h,day		; Find day number
		call	parsenum
		mov	l,a		; Add it to the start of the month
		mov	h,c		; (C is still zero) - to get the day
		dad	d		; number (still not counting Tibs)
		dcx	h		; One less (so we have day numbering at 0)
		push	h		; Keep day number
		lxi	d,-365		; Make sure it isn't >365
		dad	d
		jc	argerror	; Give an error otherwise
		pop	h		; Restore day number
		push	h 		; Keep it around
		;; Calculate Erisian weekday
		lxi	d,-5		; It's not worth it being clever here
weekcalc:	dad 	d
		jc	weekcalc
		lxi	d,5
		dad	d
		mov	b,l
		lxi	h,weekdays	; Print the day of the week
		call	strselect
		lxi	d,commaday	; Print ", day "
		call	outs
		;; Calculate season and season day number
		pop	h		; Restore day number
		mvi	b,-1		; B will be season
		lxi	d,-73		; L will be day
seasoncalc:	inr	b		; One season further on
		dad	d		; Is 73 days less
		jc 	seasoncalc
		lxi	d,73		; Correct overshoot
		dad	d
		mov	h,b		; H:L = season:day
		inr	l		; One based for output
		push	h		; Push season and day
		mov	a,l		; Print day of season
		mvi	c,'0'-1		; Tens digit in C
seasondgts:	inr	c
		sui	10
		jnc	seasondgts
		adi	'0' + 10 	; Ones digit in A
		mov	e,c		; Tens digit
		call	oute
		mov	e,a		; Ones digit
		call	oute
		lxi	d,of		; Print " of "
		call	outs
		pop	b		; Retrieve season:day
		push	b
		lxi	h,seasons	; Print the season name
		call	strselect
		call	printyear	; "... in the YOLD NNNN ..."
		;; Is there any reason to celebrate? (day=5 or day=50)
		pop 	b		; Retrieve season:day
		mov	a,c		; Day.
		cpi	5		; is it 5?
		jz	party		; Then we party
		cpi	50 		; otherwise, is it 50?
		rnz			; If not, we're done
party:		push	b		; Keep day
		lxi	d,celebrate	; "... Celebrate ..."
		call	outs
		pop	b		; Retrieve day
		push	b
		lxi	h,holydays5	; Get holyday from 5 or 50 table
		mov	a,c
		cpi	50
		jnz	dayname
		lxi	h,holydays50
dayname:	call	strselect	; the season is still in B
		lxi	d,xday
		pop	b		; Retrieve day once more
		mov	a,c
		cpi	50
		jnz	outs		; Print 'day' or 'flux' depending
		lxi	d,xflux
		jmp	outs
		;; Parse the 2-digit number in HL. Return in B (and A)
parsenum:	mvi	b,0		; zero accumulator
		call	parsedigit	; this runs it twice
parsedigit:	mov	a,b		; B *= 10
		add	a
		mov	b,a
		add	a
		add	a
		add	b
		add	m		; Add the digit
		sui	'0'		; Subtract '0'
		mov	b,a
		inx	h
		ret
		;; Print the B'th string from HL
strselect:	mvi	a,'$'
strsearcho:	dcr	b
		jm	strfound
strsearchi:	cmp	m
		inx	h
		jnz	strsearchi
		jmp	strsearcho
strfound:	xchg
		jmp	outs
		;; Print the argument error, and exit
argerror:	lxi	d,argfmt
		;; Print the string in DE and exit
error:		call	outs
		rst	0
		;; Returns with carry flag set if A is a digit ('0'-'9').
isdigit:	cpi	'0'
		cmc
		rnc
		cpi	'9' + 1
		ret
		;; Print the string in D.
outs:		mvi	c,puts
		jmp	bdos
		;; Print character in E, keeping registers.
oute:		push	psw
		push	b
		push 	d
		push	h
		mvi	c,putch
		call	bdos
		pop	h
		pop	d
		pop	b
		pop	psw
		ret
		;; Accumulated days at start of Gregorian months
		;; (in a non-leap year)
monthdays:	dw	0,31,59,90,120,151,181,212,243,273,304,334
		;; Difference between Gregorian and Erisian year count
		;; (we don't need to bother with the year otherwise)
yearoffset:	db	1,1,6,6
		;; This is matched to MMDD to handle St. Tib's Day
leap:		db	'0229'
		;; Strings
argfmt:		db	'DDATE MMDDYYYY$'
weekdays:	db	'Sweetmorn$Boomtime$Pungenday$Prickle-Prickle$'
		db	'Setting Orange$'
commaday:	db	', day $'
of:		db	' of $'
seasons:	db	'Chaos$Discord$Confusion$Bureaucracy$The Aftermath$'
celebrate:	db	': celebrate $'
holydays5:	db	'Mung$Mojo$Sya$Zara$Mala$'
xday:		db	'day!$'
holydays50:	db	'Chao$Disco$Confu$Bure$Af$'
xflux:		db	'flux!$'
tibsday:	db	'Saint Tib',39,'s Day$'
yold:		db	' in the YOLD $'


import Stream._

object MDR extends App {

  def mdr(x: BigInt, base: Int = 10): (BigInt, Long) = {
    def multiplyDigits(x: BigInt): BigInt = ((x.toString(base) map (_.asDigit)) :\ BigInt(1))(_*_)
    def loop(p: BigInt, c: Long): (BigInt, Long) = if (p < base) (p, c) else loop(multiplyDigits(p), c+1)
    loop(multiplyDigits(x), 1)
  }

  printf("%15s\t%10s\t%s\n","Number","MDR","MP")
  printf("%15s\t%10s\t%s\n","======","===","==")
  Seq[BigInt](123321, 7739, 893, 899998, BigInt("393900588225"), BigInt("999999999999")) foreach {x =>
    val (s, c) = mdr(x)
    printf("%15s\t%10s\t%2s\n",x,s,c)
  }
  println

  val mdrs: Stream[Int] => Stream[(Int, BigInt)] = i => i map (x => (x, mdr(x)._1))

  println("MDR: [n0..n4]")
  println("==== ========")
  ((for {i <- 0 to 9} yield (mdrs(from(0)) take 11112 toList) filter {_._2 == i})
    .map {_ take 5} map {xs => xs map {_._1}}).zipWithIndex
    .foreach{p => printf("%3s: [%s]\n",p._2,p._1.mkString(", "))}

}


		;; DDATE for MS-DOS (assembles using nasm)
		bits	16
		cpu	8086
tlength:	equ	80h
cmdtail:	equ	81h
putch:		equ	2
puts:		equ	9
getdate:	equ	2Ah
		org	100h
section		.text
		;; Check if a date was given
		mov	bl,[tlength]	; Length of command line
		and	bl,bl		; Is it zero?
		jz	gettoday	; Then get today's date
		;; Parse the date given on the command line
		cmp	bl,10+1		; MM/DD/YYYY is ten characters long
		jne	printusage	; If it doesn't match, print usage.
		xor	bh,bh
		add 	bx,cmdtail
		mov	byte [bx],0	; Zero terminate the date
		mov	si,cmdtail+1	; Get month,
		call	atoi
		mov	dh,al		; store in DH,
		inc	si		; get day,
		call	atoi
		mov 	dl,al		; store in DL,
		inc	si		; get year,
		call	atoi
		mov	cx,ax		; and store in CX.
		jmp	convertdate
		;; Ask MS-DOS for the date
gettoday:	mov	ah,puts		; Prefix output with 'Today is '
		mov	dx,todayis
		int	21h
		mov	ah,getdate	; And get the current date.
		int	21h
		;; Convert the date to the Discordian calendar
		;; (DL=day, DH=month, CX=year)
convertdate:	add	cx,1166		; Erisian year is 1166 years onwards.
		cmp 	dx,21dh		; Is it St. Tib's Day?
		jne	notibs
		mov	dx,tibsday 	; If yes, print "St. Tib's Day"
		mov	ah,puts
		int	21h
		;; Print "in the YOLD NNNN" and then end.
intheyold:	mov	dx,yold		; In the YOLD
		mov	ah,puts
		int	21h
		mov	ax,cx		; print the year
		call	printn
		ret			; If Tibs, this ends the program.
		;; It isn't St. Tib's Day.
notibs:		cmp	dh,1		; Month < 1 = error
		jb	printinval
		cmp	dl,1		; Day < 1 = error
		jb	printinval
		cmp	dh,12		; Month > 12 = error
		ja	printinval
		mov	bx,monthlengths-1
		xor	ah,ah		; Day higher than it should be
		mov	al,dh		; (according to month table)
		add	bx,ax		; = error
		cmp	dl,[bx]
		ja	printinval
		mov	bx,monthdays-2	; Calculate day of year
		mov	al,dh		; Cumulative months
		sal	al,1		; Multiply by 2 (2 bits per entry)
		add	bx,ax
		mov	ax,[bx]		; Days since start of month
		xor	dh,dh
		add	dx,ax		; Add day of month
		dec	dx		; Start at 0 (For array lookup)
		mov	ax,dx		; Get weekday
		mov	bl,5		; Divide by 5
		div	bl		; AH = weekday (modulo)
		mov	bl,ah
		mov	di,weekdays
		call	strselect	; Print the weekday
		mov	bx,dx		; Keep day of year in bx for now
		mov	dx,commaday	; ... ', day '
		call	printstr
		mov	dl,73		; Each season is 73 days long
		mov	ax,bx		; Divide day of year by 73
		div	dl		; DH=AH=day of season (modulo)
		mov	dx,ax		; DL=AL=season number
		xor	ah,ah		; Print day of season
		mov	al,dh
		inc	al		; One more (days do start at 1)
		call	printn
		mov	bx,dx		; Store day and season in bx
		mov	dx,of		; Print ... ' of '
		call	printstr
		mov	dx,bx		; Day and season in dx again
		mov	di,seasons	; Print season
		call	strselect	; BL is still season number
		mov	bx,dx		; Day and season in BX again.
		call	intheyold	; Print the year
		cmp	bh,5-1		; Something to celebrate?
		je	party		; (Day 5 or 50?
		cmp	bh,50-1
		je	party
		ret			; If not, stop.
party:		mov	al,bh		; Day in AL.
		mov	bx,holydays5	; Day 5 holydays.
		mov	cx,xday
		cmp	al,50-1		; Unless it's 50
		jne	holyday
		mov	bx,holydays50	; Then we need day 50 holydays.
		mov	cx,xflux
holyday:	mov	dx,celebrate	; Print ... ', celebrate: '
		call	printstr
		mov	dx,bx
		call	printstr
		mov	dx,cx
		jmp	printstr
		;; Print "invalid date".
printinval:	mov	dx,inval
		jmp	printstr
		;; Print usage.
printusage:	mov	dx,usage
		;; Print DX.
printstr:	mov	ah,puts
		int	21h
		ret
		;; Subroutine: print the BL'th string from DI
strselect:	inc	bl		; Counter the 'dec bl' later
		mov	al,'$'		; String end
		push	cx		; Keep registers
		push	dx
.search		dec	bl		; Are we there yet?
		jz	.found
		mov	cx,-1
		repne	scasb 		; Scan to end of string
		jmp	.search
.found		mov	dx,di		; Found the string, print it
		mov	ah,puts
		int	21h
		pop	dx		; Restore registers
		pop	cx
		ret
		;; Subroutine: print number in AX.
printn:		push	cx		; Don't trample registers
		push	dx
		mov	si,numend 	; End of number string.
		mov	cx,10 		; Divisor, ten.
.loop		xor	dx,dx		; Zero DX.
		dec	si		; Back up one digit.
		div	cx		; Divide AX by ten.
		add	dl,'0'		; Remainder is now in DX; make ASCII
		mov	[si],dl		; and store.
		and	ax,ax		; Quotient is in AX, check if zero
		jnz	.loop 		; loop for next digit if there is one.
		mov	dx,si		; Print SI - move it to DX,
		mov	ah,puts		; and then call the DOS print function
		int	21h
		pop	dx		; Restore the registers
		pop	cx
		ret
		;; Subroutine: parse number at [SI], store in AX.
atoi:		push	bx		; Don't trample registers
		push	cx
		push	dx
		xor	ax,ax		; Zero AX.
		xor	bh,bh		; BH as well.
		mov	cx,10		; Multiplier, ten.
.loop		mov	bl,[si]		; Current number.
		sub	bl,'0'		; Subtract '0'.
		jc	.done		; If <0, then done.
		cmp	bl,9		; If it's higher than 9,
		jnbe	.done		; also done.
		mul	cx		; Multiply accumulator by 10
		add	ax,bx		; Add the digit in.
		inc	si		; Next digit
		jmp	.loop
.done		pop	dx		; Restore registers
		pop	cx
		pop	bx
		ret
section		.data
		;; Accumulated days at start of Gregorian months
monthdays:	dw	0,31,59,90,120,151,181,212,243,273,304,334
		;; Days per month
monthlengths:	db	31,28,31,30,31,30,31,31,30,31,30,31
		;; Strings
inval:		db	'Invalid date.$'
usage:		db	`DDATE [MM/DD/YYYY]\r\n`
		db	`\r\n\tPrint today's date or the given date in the`
		db	` Discordian calendar.$`
number:		db	'00000'
numend:		db	'$'
todayis:	db	'Today is $'
weekdays:	db	'Sweetmorn$Boomtime$Pungenday$Prickle-Prickle$'
		db	'Setting Orange$'
commaday:	db	', day $'
of:		db	' of $'
seasons:	db	'Chaos$Discord$Confusion$Bureaucracy$The Aftermath$'
celebrate:	db	': celebrate $'
holydays5:	db	'Mung$Mojo$Sya$Zara$Mala$'
xday:		db	'day!$'
holydays50:	db	'Chao$Disco$Confu$Bure$Af$'
xflux:		db	'flux!$'
tibsday:	db	"Saint Tib's Day$"
yold:		db	' in the YOLD $'


with javascript_semantics
function throwDie(integer nSides, nDice, s, sequence counts)
    if nDice == 0 then
        counts[s] += 1
    else
        for i=1 to nSides do
            counts = throwDie(nSides, nDice-1, s+i, counts)
        end for
    end if
    return counts
end function

function beatingProbability(integer nSides1, nDice1, nSides2, nDice2)
    integer len1 := (nSides1 + 1) * nDice1,
            len2 := (nSides2 + 1) * nDice2
    sequence c1 = throwDie(nSides1, nDice1, 0, repeat(0,len1)),
             c2 = throwDie(nSides2, nDice2, 0, repeat(0,len2))
    atom p12 := power(nSides1, nDice1) * power(nSides2, nDice2),
         tot := 0.0
    for i=1 to len1 do
        for j=1 to min(i-1,len2) do
            tot += (c1[i] * c2[j]) / p12
        end for
    end for
    return tot
end function

printf(1,"%0.16f\n",beatingProbability(4, 9, 6, 6))
printf(1,"%0.16f\n",beatingProbability(10, 5, 7, 6))


; Convert an integer into a list of its digits.

(define integer->list
  (lambda (integer)
    (let loop ((list '()) (int integer))
      (if (< int 10)
        (cons int list)
        (loop (cons (remainder int 10) list) (quotient int 10))))))

; Return the product of the digits of an integer.

(define integer-product-digits
  (lambda (integer)
    (fold-left * 1 (integer->list integer))))

; Compute the multiplicative digital root and multiplicative persistence of an integer.
; Return as a cons of (mdr . mp).

(define mdr-mp
  (lambda (integer)
    (let loop ((int integer) (cnt 0))
      (if (< int 10)
        (cons int cnt)
        (loop (integer-product-digits int) (1+ cnt))))))

; Emit a table of integer, multiplicative digital root, and multiplicative persistence
; for the example integers given.  Example list ends with sequence A003001 from OEIS.

(printf "[email protected] [email protected] [email protected]~%" "Integer" "Root" "Pers.")
(printf "[email protected] [email protected] [email protected]~%" "===============" "======" "======")
(let rowloop ((intlist '(123321 7739 893 899998
                         0 10 25 39 77 679 6788 68889 2677889 26888999 3778888999 277777788888899)))
  (when (pair? intlist)
    (let* ((int (car intlist))
           (mm (mdr-mp int)))
      (printf "[email protected] [email protected] [email protected]~%" int (car mm) (cdr mm))
      (rowloop (cdr intlist)))))

; Emit a table of multiplicative digital root versus the first five integers having that MDR.

(newline)
(printf "[email protected] ~a~%" "Root" "First five integers with that root")
(printf "[email protected] ~a~%" "====" "==================================")
(let ((mdrslsts (make-vector 10 '())))
  (do ((integer 0 (1+ integer)))
      ((>= (fold-left min 5 (vector->list (vector-map length mdrslsts))) 5))
    (let ((mdr (car (mdr-mp integer))))
      (when (< (length (vector-ref mdrslsts mdr)) 5)
        (vector-set! mdrslsts mdr (append (vector-ref mdrslsts mdr) (list integer))))))
  (do ((mdr 0 (1+ mdr)))
      ((>= mdr 10))
    (printf "[email protected]" mdr)
    (for-each (lambda (int) (printf "[email protected]" int)) (vector-ref mdrslsts mdr))
    (newline)))


with Ada.Calendar.Arithmetic;
with Ada.Text_IO;
with Ada.Integer_Text_IO;
with Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Text_IO;
with Ada.Command_Line;

procedure Discordian is
   use Ada.Calendar;
   use Ada.Strings.Unbounded;
   use Ada.Command_Line;
   package UStr_IO renames Ada.Strings.Unbounded.Text_IO;

   subtype Year_Number is Integer range 3067 .. 3565;
   type Seasons is (Chaos, Discord, Confusion, Bureaucracy, The_Aftermath);
   type Days_Of_Week is (Sweetmorn, Boomtime, Pungenday,
                         Prickle_Prickle, Setting_Orange);
   subtype Day_Number is Integer range 1 .. 73;

   type Discordian_Date is record
      Year        : Year_Number;
      Season      : Seasons;
      Day         : Day_Number;
      Week_Day    : Days_Of_Week;
      Is_Tibs_Day : Boolean := False;
   end record;

   function Week_Day_To_Str(Day : Days_Of_Week) return Unbounded_String is
      s : Unbounded_String;
   begin
      case Day is
         when Sweetmorn       => s := To_Unbounded_String("Sweetmorn");
         when Boomtime        => s := To_Unbounded_String("Boomtime");
         when Pungenday       => s := To_Unbounded_String("Pungenday");
         when Prickle_Prickle => s := To_Unbounded_String("Prickle-Prickle");
         when Setting_Orange  => s := To_Unbounded_String("Setting Orange");
      end case;
      return s;
   end Week_Day_To_Str;

   function Holiday(Season: Seasons) return Unbounded_String is
      s : Unbounded_String;
   begin
      case Season is
         when Chaos         => s := To_Unbounded_String("Chaoflux");
         when Discord       => s := To_Unbounded_String("Discoflux");
         when Confusion     => s := To_Unbounded_String("Confuflux");
         when Bureaucracy   => s := To_Unbounded_String("Bureflux");
         when The_Aftermath => s := To_Unbounded_String("Afflux");
      end case;
      return s;
   end Holiday;

   function Apostle(Season: Seasons) return Unbounded_String is
      s : Unbounded_String;
   begin
      case Season is
         when Chaos         => s := To_Unbounded_String("Mungday");
         when Discord       => s := To_Unbounded_String("Mojoday");
         when Confusion     => s := To_Unbounded_String("Syaday");
         when Bureaucracy   => s := To_Unbounded_String("Zaraday");
         when The_Aftermath => s := To_Unbounded_String("Maladay");
      end case;
      return s;
   end Apostle;

   function Season_To_Str(Season: Seasons) return Unbounded_String is
      s : Unbounded_String;
   begin
      case Season is
         when Chaos         => s := To_Unbounded_String("Chaos");
         when Discord       => s := To_Unbounded_String("Discord");
         when Confusion     => s := To_Unbounded_String("Confusion");
         when Bureaucracy   => s := To_Unbounded_String("Bureaucracy");
         when The_Aftermath => s := To_Unbounded_String("The Aftermath");
      end case;
      return s;
   end Season_To_Str;

   procedure Convert (From : Time; To : out Discordian_Date) is
      use Ada.Calendar.Arithmetic;
      First_Day   : Time;
      Number_Days : Day_Count;
      Leap_Year   : boolean;
   begin
      First_Day   := Time_Of (Year => Year (From), Month => 1, Day => 1);
      Number_Days := From - First_Day;

      To.Year        := Year (Date => From) + 1166;
      To.Is_Tibs_Day := False;
      Leap_Year := False;
      if Year (Date => From) mod 4 = 0 then
          if Year (Date => From) mod 100 = 0 then
              if Year (Date => From) mod 400 = 0 then
                  Leap_Year := True;
              end if;
          else
              Leap_Year := True;
          end if;
      end if;
      if Leap_Year then
         if Number_Days > 59 then
            Number_Days := Number_Days - 1;
         elsif Number_Days = 59 then
            To.Is_Tibs_Day := True;
         end if;
      end if;
      To.Day := Day_Number (Number_Days mod 73 + 1);
      case Number_Days / 73 is
         when 0 => To.Season := Chaos;
         when 1 => To.Season := Discord;
         when 2 => To.Season := Confusion;
         when 3 => To.Season := Bureaucracy;
         when 4 => To.Season := The_Aftermath;
         when others => raise Constraint_Error;
      end case;
      case Number_Days mod 5 is
         when 0 => To.Week_Day := Sweetmorn;
         when 1 => To.Week_Day := Boomtime;
         when 2 => To.Week_Day := Pungenday;
         when 3 => To.Week_Day := Prickle_Prickle;
         when 4 => To.Week_Day := Setting_Orange;
         when others => raise Constraint_Error;
      end case;
   end Convert;

   procedure Put (Item : Discordian_Date) is
   begin
      if Item.Is_Tibs_Day then
         Ada.Text_IO.Put ("St. Tib's Day");
      else
         UStr_IO.Put (Week_Day_To_Str(Item.Week_Day));
         Ada.Text_IO.Put (", day" & Integer'Image (Item.Day));
         Ada.Text_IO.Put (" of ");
         UStr_IO.Put (Season_To_Str (Item.Season));
         if Item.Day = 5 then
            Ada.Text_IO.Put (", ");
            UStr_IO.Put (Apostle(Item.Season));
         elsif Item.Day = 50 then
            Ada.Text_IO.Put (", ");
            UStr_IO.Put (Holiday(Item.Season));
         end if;
      end if;
      Ada.Text_IO.Put (" in the YOLD" & Integer'Image (Item.Year));
      Ada.Text_IO.New_Line;
   end Put;

   Test_Day  : Time;
   Test_DDay : Discordian_Date;
   Year : Integer;
   Month : Integer;
   Day : Integer;
   YYYYMMDD : Integer;
begin

   if Argument_Count = 0 then
      Test_Day := Clock;
      Convert (From => Test_Day, To => Test_DDay);
      Put (Test_DDay);
   end if;

   for Arg in 1..Argument_Count loop

      if Argument(Arg)'Length < 8 then
         Ada.Text_IO.Put("ERROR: Invalid Argument : '" & Argument(Arg) & "'");
         Ada.Text_IO.Put("Input format YYYYMMDD");
         raise Constraint_Error;
      end if;

      begin
         YYYYMMDD := Integer'Value(Argument(Arg));
      exception
         when Constraint_Error =>
            Ada.Text_IO.Put("ERROR: Invalid Argument : '" & Argument(Arg) & "'");
            raise;
      end;

      Day := YYYYMMDD mod 100;
      if Day < Day_Number'First or Day > Day_Number'Last then
         Ada.Text_IO.Put("ERROR: Invalid Day:" & Integer'Image(Day));
         raise Constraint_Error;
      end if;

      Month := ((YYYYMMDD - Day) / 100) mod 100;
      if Month < Month_Number'First or Month > Month_Number'Last then
         Ada.Text_IO.Put("ERROR: Invalid Month:" & Integer'Image(Month));
         raise Constraint_Error;
      end if;

      Year := ((YYYYMMDD - Day - Month * 100) / 10000);
      if Year < 1901 or Year > 2399 then
         Ada.Text_IO.Put("ERROR: Invalid Year:" & Integer'Image(Year));
         raise Constraint_Error;
      end if;

      Test_Day := Time_Of (Year => Year, Month => Month, Day => Day);

      Convert (From => Test_Day, To => Test_DDay);
      Put (Test_DDay);

   end loop;

end Discordian;


*process source attributes xref;
 dicegame: Proc Options(main);
 Call test(9, 4,6,6);
 Call test(5,10,6,7);
 test: Proc(w1,s1,w2,s2);
 Dcl (w1,s1,w2,s2,x,y) Bin Fixed(31);
 Dcl p1(100)    Dec Float(18) Init((100)0);
 Dcl p2(100)    Dec Float(18) Init((100)0);
 Dcl p2low(100) Dec Float(18) Init((100)0);
 Call pp(w1,s1,p1);
 Call pp(w2,s2,p2);
 Do x=w1 To w1*s1;
   Do y=0 To x-1;
     p2low(x)+=p2(y);
     End;
   End;
 pwin1=0;
 Do x=w1 To w1*s1;
  pwin1+=p1(x)*p2low(x);
  End;
 Put Edit('Player 1 has ',w1,' dice with ',s1,' sides each')
         (Skip,3(a,f(2)));
 Put Edit('Player 2 has ',w2,' dice with ',s2,' sides each')
         (Skip,3(a,f(2)));
 Put Edit('Probability for player 1 to win: ',pwin1)(Skip,a,f(20,18));
 Put Edit('')(Skip,a);
 End;
 pp: Proc(w,s,p);
 /*--------------------------------------------------------------------
 * Compute and assign probabilities to get a sum x
 * when throwing w dice each having s sides (marked from 1 to s)
 *-------------------------------------------------------------------*/
 Dcl (w,s)    Bin Fixed(31);
 Dcl p(100)   Dec Float(18);
 Dcl cnt(100) Bin Fixed(31);
 Dcl (a(12),e(12),v(12),sum,i,n) Bin Fixed(31);
 a=0;
 e=0;
 Do i=1 To w;
   a(i)=1;
   e(i)=s;
   End;
 n=0;
 cnt=0;
 Do v(1)=a(1) To e(1);
   Do v(2)=a(2) To e(2);
     Do v(3)=a(3) To e(3);
       Do v(4)=a(4) To e(4);
         Do v(5)=a(5) To e(5);
           Do v(6)=a(6) To e(6);
             Do v(7)=a(7) To e(7);
               Do v(8)=a(8) To e(8);
                 Do v(9)=a(9) To e(9);
                   Do v(10)=a(10) To e(10);
                     sum=0;
                     Do i=1 To 10;
                       sum=sum+v(i);
                       End;
                     cnt(sum)+=1;
                     n+=1;
                     End;
                   End;
                 End;
               End;
             End;
           End;
         End;
       End;
     End;
   End;
 Do k=w To w*s;
   p(k)=divide(cnt(k),n,18,16);
   End;
 End;
 End;


func mdroot(n) {
  var (mdr, persist) = (n, 0)
  while (mdr >= 10) {
    mdr = mdr.digits.prod
    ++persist
  }
  [mdr, persist]
}

say "Number: MDR  MP\n======  ===  =="
[123321, 7739, 893, 899998].each{|n| "%6d: %3d %3d\n" \
                           .printf(n, mdroot(n)...) }

var counter = Hash()

Inf.times { |j|
  counter{mdroot(j).first} := [] << j
  break if counter.values.all {|v| v.len >= 5 }
}

say "\nMDR: [n0..n4]\n===  ========"
10.times {|i| "%3d: %s\n".printf(i, counter{i}.first(5)) }


proc mdr {n} {
    if {$n < 0 || ![string is integer $n]} {
	error "must be an integer"
    }
    for {set i 0} {$n > 9} {incr i} {
	set n [tcl::mathop::* {*}[split $n ""]]
    }
    return [list $i $n]
}


BEGIN #   DISCORDIAN DATE CALCULATION - TRANSLATION OF MAD VIA ALGOL W    #
    INT      greg, gmonth, gday, gyear;
    []STRING holys  = []STRING( "MUNG", "MOJO",  "SYA",   "ZARA", "MALA" )[ AT 0 ];
    []STRING holys0 = []STRING( "CHAO", "DISCO", "CONFU", "BURE", "AF"   )[ AT 0 ];
    []STRING disday = []STRING( "SWEETMORN", "BOOMTIME", "PUNGENday", "PRICKLE-PRICKLE", "SETTING ORANGE" )[ AT 0 ];
    []STRING disssn = []STRING( "CHAOS",     "DISCORD",  "CONFUSION", "BUREAUCRACY",     "THE AFTERMATH"  )[ AT 0 ];
    []INT    mlengt = []INT( 0, 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334 )[ AT 0 ];
    CHAR     slash1, slash2;

    # input date should contain MM/DD/YYYY in the gregorian calendar      #
    read( ( gmonth, slash1, gday, slash2, gyear ) );
    IF slash1 /= "/" OR slash2 /= "/" THEN print( ( "Invalid date format", newline ) ); stop FI;

    IF gmonth = 2 AND gday = 29
    THEN print( ( "SAINT TIB'S DAY IN THE Y.O.L.D. ", whole( gyear + 1166, -4 ), newline ) )
    ELSE
        INT yrday  := mlengt[ gmonth ] + gday;
        INT season := yrday OVER 73;
        INT day    := yrday - ( season * 73 );
        INT wkday  := ( yrday - 1 ) MOD 5;
        print( ( disday[ wkday ], ", DAY ", whole( day, -2 ), " OF ", disssn[ season ]
               , " IN THE Y.O.L.D ", whole( gyear + 1166, 0 ), newline
               )
             );
        IF   day = 5  THEN print( ( "CELEBRATE ", holys[  season ], "DAY"  ) )
        ELIF day = 50 THEN print( ( "CELEBRATE ", holys0[ season ], "FLUX" ) )
        FI
    FI
END


from itertools import product

def gen_dict(n_faces, n_dice):
    counts = [0] * ((n_faces + 1) * n_dice)
    for t in product(range(1, n_faces + 1), repeat=n_dice):
        counts[sum(t)] += 1
    return counts, n_faces ** n_dice

def beating_probability(n_sides1, n_dice1, n_sides2, n_dice2):
    c1, p1 = gen_dict(n_sides1, n_dice1)
    c2, p2 = gen_dict(n_sides2, n_dice2)
    p12 = float(p1 * p2)

    return sum(p[1] * q[1] / p12
               for p, q in product(enumerate(c1), enumerate(c2))
               if p[0] > q[0])

print beating_probability(4, 9, 6, 6)
print beating_probability(10, 5, 7, 6)


probability <- function(facesCount1, diceCount1, facesCount2, diceCount2)
{
  mean(replicate(10^6, sum(sample(facesCount1, diceCount1, replace = TRUE)) > sum(sample(facesCount2, diceCount2, replace = TRUE))))
}
cat("Player 1's probability of victory is", probability(4, 9, 6, 6),
    "in the first game and", probability(10, 5, 7, 6), "in the second.")


// Only valid for n > 0 && base >= 2
fn mult(nn u64, base int) u64 {
	mut n := nn
	mut mult := u64(0)
	for mult = 1; mult > 0 && n > 0; n /= u64(base) {
		mult *= n % u64(base)
	}
	return mult
}

// Only valid for n >= 0 && base >= 2
fn multi_digital_root(n u64, base int) (int, int) {
	mut m := u64(0)
	mut mp := 0
	for m = n; m >= u64(base); mp++ {
		m = mult(m, base)
	}
	return mp, int(m)
}
const base = 10

fn main() {
	size := 5

	println("${'Number':20} ${'MDR':3} ${'MP':3}")
	for n in [
		u64(123321), 7739, 893, 899998,
		18446743999999999999,
		// From http://mathworld.wolfram.com/MultiplicativePersistence.html
		3778888999, 277777788888899,
	 ] {
		mp, mdr := multi_digital_root(n, base)
		println("${n:20} ${mdr:3} ${mp:3}")
	}
	println('')

	mut list := [base][]u64{init: []u64{len: 0, cap:size}}
	for cnt, n := size*base, u64(0); cnt > 0; n++ {
		_, mdr := multi_digital_root(n, base)
		if list[mdr].len < size {
			list[mdr] << n
			cnt--
		}
	}
	println("${'MDR':3}: First")
	for i, l in list {
		println("${i:3}: $l")
	}
}


import "/big" for BigInt
import "/fmt" for Fmt

// Only valid for n > 0 && base >= 2
var mult = Fn.new { |n, base|
    var m = BigInt.one
    while (m > BigInt.zero && n > BigInt.zero) {
        var dm = n.divMod(base)
        m = m * dm[1]
        n = dm[0]
    }
    return m
}

// Only valid for n >= 0 && base >= 2
var multDigitalRoot = Fn.new { |n, base|
    base = BigInt.new(base)
    var m = n.copy()
    var mp = BigInt.zero
    while (m >= base) {
        m = mult.call(m, base)
        mp = mp.inc
    }
    return [mp, m.toSmall]
}

var base = 10
var size = 5

var tests = [
    123321, 7739, 893, 899998,"18446743999999999999", 3778888999, "277777788888899"
]

var testFmt = "$20s $3s $3s"
Fmt.print(testFmt, "Number", "MDR", "MP")
for (test in tests) {
    var n = BigInt.new(test)
    var mpdr = multDigitalRoot.call(n, base)
    Fmt.print(testFmt, n, mpdr[1], mpdr[0])
}
System.print()

var list = List.filled(base, null)
for (i in 0...base) list[i] = []
var cnt = size * base
var n = BigInt.zero
while (cnt > 0) {
    var mpdr = multDigitalRoot.call(n, base)
    var mdr = mpdr[1]
    if (list[mdr].count < size) {
        list[mdr].add(n)
        cnt = cnt - 1
    }
    n = n.inc
}
Fmt.print("$3s: $s", "MDR", "First")
var i = 0
for (l in list) {
    Fmt.print("$3d: $s", i, l.toString)
    i = i + 1
}


BEGIN %   DISCORDIAN DATE CALCULATION - TRANSLATION OF MAD                %
    INTEGER          GREG, GMONTH, GDAY, GYEAR;
    STRING(16) ARRAY HOLY5  ( 0 ::  4 );
    STRING(16) ARRAY HOLY50 ( 0 ::  4 );
    STRING(16) ARRAY DISDAY ( 0 ::  4 );
    STRING(16) ARRAY DISSSN ( 0 ::  4 );
    INTEGER    ARRAY MLENGT ( 0 :: 12 );
    INTEGER          APOS;
    STRING(1)        SLASH1, SLASH2;

    % WRITES A "$" TERMINATED STRING                                      %
    PROCEDURE WRITEONTEXT( STRING(16) VALUE TEXT ) ;
    BEGIN
        INTEGER TPOS;
        TPOS := 0;
        WHILE TPOS < 16 DO BEGIN
            IF TEXT( TPOS // 1 ) = "$"
            THEN TPOS := 32
            ELSE WRITEON( TEXT( TPOS // 1 ) );
            ;
            TPOS := TPOS + 1
        END WHILE_TPOS_LT_16
    END WRITEONTEXT;

    APOS := 0;
    FOR M := 0,0,31,59,90,120,151,181,212,243,273,304,334 DO BEGIN MLENGT(APOS) := M; APOS := APOS + 1 END;
    HOLY5 (0) := "MUNG$";HOLY5 (1) := "MOJO$"; HOLY5 (2) := "SYA$";  HOLY5 (3) := "ZARA$"; HOLY5 (4) := "MALA$";
    HOLY50(0) := "CHAO$";HOLY50(1) := "DISCO$";HOLY50(2) := "CONFU$";HOLY50(3) := "BURE$"; HOLY50(4) := "AF$";
    DISDAY(0) := "SWEETMORN$";       DISDAY(1) := "BOOMTIME$";      DISDAY(2) := "PUNGENDAY$";
    DISDAY(3) := "PRICKLE-PRICKLE$"; DISDAY(4) := "SETTING ORANGE$";
    DISSSN(0) := "CHAOS$"; DISSSN(1) := "DISCORD$"; DISSSN(2) := "CONFUSION$";
    DISSSN(3) := "BUREAUCRACY$"; DISSSN(4) := "THE AFTERMATH$";

    % INPUT DATE SHOULD CONTAIN MM/DD/YYYY IN GREGORIAN CALENDAR          %
    READ( GMONTH, SLASH1, GDAY, SLASH2, GYEAR );

    IF GMONTH = 2 AND GDAY = 29
    THEN WRITE( I_W := 4, S_W := 0, "SAINT TIB'S DAY IN THE Y.O.L.D. ", GYEAR + 1166 )
    ELSE BEGIN
        INTEGER YRDAY, SEASON, DAY, WKDAY;
        YRDAY  := MLENGT(GMONTH)+GDAY;
        SEASON := YRDAY DIV 73;
        DAY    := YRDAY-SEASON*73;
        WKDAY  := (YRDAY-1) REM 5;
        WRITEONTEXT( DISDAY(WKDAY) );
        WRITEON( S_W := 0, ", DAY ", I_W := 2, DAY, " OF " );
        WRITEONTEXT( DISSSN(SEASON) );
        WRITEON( S_W := 0, " IN THE Y.O.L.D ", I_W := 4, GYEAR + 1166 );
        IF      DAY = 5  THEN BEGIN
            WRITE( "CELEBRATE " );WRITEONTEXT( HOLY5(SEASON) );  WRITEON( "DAY"  )
            END
        ELSE IF DAY = 50 THEN BEGIN
            WRITE( "CELEBRATE " );WRITEONTEXT( HOLY50(SEASON) ); WRITEON( "FLUX" )
        END IF_FAY_EQ_5__DAY_EQ_50
    END
END.


on gregorianToDiscordian(inputDate) -- Input: AppleScript date object.
    (*
        Discordian years are aligned with, and the same length as, Gregorian years.
        Each has 73 5-day weeks and 5 73-day seasons. (73 * 5 = 365.)
        The first day of a Discordian year is also that of its first week and first season.
        In leap years, an extra day called "St. Tib's Day", is inserted between days 59 and 60.
        It's considered to be outside the calendar, so the day after it is Setting Orange, Chaos 60,
        not Sweetmorn, Chaos 61. Year 1 YOLD is 1166 BC, but this handler takes an AS date object
        as its input and is only good for AD Gregorian dates. Since the Discordian calendar's an
        American invention, the output here's in the US style: "Weekday, Season day, year".
    *)
    -- Calculate the input date's day-of-year number.
    copy inputDate to startOfYear
    tell startOfYear to set {its day, its month} to {1, January}
    set dayOfYear to (inputDate - startOfYear) div days + 1

    -- If it's a leap year, special-case St. Tib's Day, or adjust the day-of-year number if the day comes after that.
    set y to inputDate's year
    if ((y mod 4 is 0) and ((y mod 100 > 0) or (y mod 400 is 0))) then
        if (dayOfYear is 60) then
            set dayOfYear to "St. Tib's Day"
        else if (dayOfYear > 60) then
            set dayOfYear to dayOfYear - 1
        end if
    end if

    -- Start the output text with either "St. Tib's Day" or the weekday, season, and day-of-season number.
    if (dayOfYear is "St. Tib's Day") then
        set outputText to dayOfYear
    else
        tell dayOfYear - 1
            set dayOfWeek to it mod 5 + 1
            set seasonNumber to it div 73 + 1
            set dayOfSeason to it mod 73 + 1
        end tell
        set theWeekdays to {"Sweetmorn", "Boomtime", "Pungenday", "Prickle-Prickle", "Setting Orange"}
        set theSeasons to {"Chaos ", "Discord ", "Confusion ", "Bureaucracy ", "The Aftermath "}
        set outputText to (item dayOfWeek of theWeekdays) & ", " & (item seasonNumber of theSeasons) & dayOfSeason
    end if

    -- Append the Discordian year number and return the result.
    return outputText & ", " & (y + 1166)
end gregorianToDiscordian

set ASDate to (current date)
set gregorianDate to ASDate's date string
set discordianDate to gregorianToDiscordian(ASDate)
return {Gregorian:gregorianDate, Discordian:discordianDate}


#lang racket

(define probs# (make-hash))

(define (NdD n d)
  (hash-ref!
   probs# (cons n d)
   (λ ()
     (cond
       [(= n 0) ; every chance of nothing!
        (hash 0 1)]
       [else
        (for*/fold ((hsh (hash))) (((i p) (in-hash (NdD (sub1 n) d))) (r (in-range 1 (+ d 1))))
          (hash-update hsh (+ r i) (λ (p+) (+ p+ (/ p d))) 0))]))))

(define (game-probs N1 D1 N2 D2)
  (define P1 (NdD N1 D1))
  (define P2 (NdD N2 D2))
  (define-values (W D L)
    (for*/fold ((win 0) (draw 0) (lose 0)) (((r1 p1) (in-hash P1)) ((r2 p2) (in-hash P2)))
      (define p (* p1 p2))
      (cond
        [(< r1 r2) (values win draw (+ lose p))]
        [(= r1 r2) (values win (+ draw p) lose)]
        [(> r1 r2) (values (+ win p) draw lose)])))

  (printf "P(P1 win): ~a~%" (real->decimal-string W 6))
  (printf "P(draw):   ~a~%" (real->decimal-string D 6))
  (printf "P(P2 win): ~a~%" (real->decimal-string L 6))
  (list W D L))

(printf "GAME 1 (9D4 vs 6D6)~%")
(game-probs 9 4 6 6)
(newline)

(printf "GAME 2 (5D10 vs 6D7) [what is a D7?]~%")
(game-probs 5 10 6 7)


sub likelihoods ($roll) {
    my ($dice, $faces) = $roll.comb(/\d+/);
    my @counts;
    @counts[$_]++ for [X+] |(1..$faces,) xx $dice;
    return [@counts[]:p], $faces ** $dice;
}

sub beating-probability ([$roll1, $roll2]) {
    my (@c1, $p1) := likelihoods $roll1;
    my (@c2, $p2) := likelihoods $roll2;
    my $p12 = $p1 * $p2;

    [+] gather for flat @c1 X @c2 -> $p, $q {
	take $p.value * $q.value / $p12 if $p.key > $q.key;
    }
}

# We're using standard DnD notation for dice rolls here.
say .gist, "\t", .raku given beating-probability < 9d4 6d6 >;
say .gist, "\t", .raku given beating-probability < 5d10 6d7 >;


fcn mdroot(n){ // Multiplicative digital root
   mdr := List(n);
   while (mdr[-1] > 9){
      mdr.append(mdr[-1].split().reduce('*,1));
   }
   return(mdr.len() - 1, mdr[-1]);
}