langs a-z

Task/Digital-root/NetRexx/digital-root.netrexx

@@ -0,0 +1,34 @@
+/* NetRexx ************************************************************
+* Test digroot
+**********************************************************************/
+Say 'number -> digital_root persistence'
+test_digroot(7           ,7, 0)
+test_digroot(627615      ,9, 2)
+test_digroot(39390       ,6, 2)
+test_digroot(588225      ,3, 2)
+test_digroot(393900588225,9, 2)
+test_digroot(393900588225,9, 3)   /* test error case */
+
+method test_digroot(n,dx,px) static
+res=digroot(n)
+Parse res d p
+If d=dx & p=px Then tag='ok'
+               Else tag='expected:' dx px
+Say n '->' d p tag
+
+method digroot(n) static
+/**********************************************************************
+* Compute the digital root and persistence of the given decimal number
+* 19.08.2012 Walter Pachl derived from Rexx
+**************************** Bottom of Data **************************/
+p=0                                 /* persistence                   */
+Loop While n.length()>1             /* more than one digit in n      */
+  s=0                               /* initialize sum                */
+  p=p+1                             /* increment persistence         */
+  Loop while n<>''                  /* as long as there are digits   */
+    Parse n c +1 n                  /* pick the first one            */
+    s=s+c                           /* add to the new sum            */
+    End
+  n=s                               /* the 'new' number              */
+  End
+return n p                          /* return root and persistence   */

Task/Digital-root/PARI-GP/digital-root.pari

@@ -0,0 +1,3 @@
+dsum(n)=my(s); while(n, s+=n%10; n\=10); s
+additivePersistence(n)=my(s); while(n>9, s++; n=dsum(n)); s
+digitalRoot(n)=if(n, (n-1)%9+1, 0)

Task/Digital-root/PL-I/digital-root.pli

@@ -0,0 +1,59 @@
+ digrt: Proc Options(main);
+ /* REXX ***************************************************************
+ * Test digroot
+ **********************************************************************/
+
+ Call digrtst('7');
+ Call digrtst('627615');
+ Call digrtst('39390');
+ Call digrtst('588225');
+ Call digrtst('393900588225');
+
+ digrtst: Proc(n);
+ Dcl n Char(100) Var;
+ Dcl dr Pic'9';
+ Dcl p  Dec Fixed(5);
+ Call digroot(n,dr,p);
+ Put Edit(n,dr,p)(skip,a,col(20),f(1),f(3));
+ End;
+
+ digroot: Proc(n,dr,p);
+ /**********************************************************************
+ * Compute the digital root and persistence of the given decimal number
+ * 27.07.2012 Walter Pachl (derived from REXX)
+ **********************************************************************/
+ Dcl n Char(100) Var;
+ Dcl dr Pic'9';
+ Dcl p  Dec Fixed(5);
+ Dcl s  Pic'(14)Z9';
+ Dcl v  Char(100) Var;
+ p=0;
+ v=strip(n);                         /* copy the number               */
+ If length(v)=1 Then
+   dr=v;
+ Else Do;
+   Do While(length(v)>1);            /* more than one digit in v      */
+     s=0;                            /* initialize sum                */
+     p+=1;                           /* increment persistence         */
+     Do i=1 To length(v);            /* loop over all digits          */
+       dig=substr(v,i,1);            /* pick a digit                  */
+       s=s+dig;                      /* add to the new sum            */
+       End;
+   /*Put Skip Data(v,p,s);*/
+     v=strip(s);                     /* the 'new' number              */
+     End;
+   dr=Decimal(s,1,0);
+   End;
+ Return;
+ End;
+
+ strip: Proc(x) Returns(Char(100) Var);
+ Dcl x Char(*);
+ Dcl res Char(100) Var Init('');
+ Do i=1 To length(x);
+   If substr(x,i,1)>' ' Then
+     res=res||substr(x,i,1);
+   End;
+ Return(res);
+ End;
+ End;

Task/Digital-root/Perl-6/digital-root-1.pl6

@@ -0,0 +1,23 @@
+sub digroot ($r, :$base = 10) {
+    my $root = $r.base($base);
+    my $persistence = 0;
+    while $root.chars > 1 {
+        $root = [+]($root.comb.map({:36($_)})).base($base);
+        $persistence++;
+    }
+    $root, $persistence;
+}
+
+my @testnums =
+    627615,
+    39390,
+    588225,
+    393900588225,
+    58142718981673030403681039458302204471300738980834668522257090844071443085937;
+
+for 10, 8, 16, 36 -> $b {
+    for @testnums -> $n {
+        printf ":$b\<%s>\ndigital root %s, persistence %s\n\n",
+            $n.base($b), digroot $n, :base($b);
+    }
+}

Task/Digital-root/Perl-6/digital-root-2.pl6

@@ -0,0 +1,6 @@
+sub digroot ($r, :$base = 10) {
+    my &sum = { [+](.comb.map({:36($_)})).base($base) }
+
+    return .[*-1], .elems-1
+        given $r.base($base), &sum ...  { .chars == 1 }
+}

Task/Digital-root/PureBasic/digital-root.purebasic

@@ -0,0 +1,49 @@
+; if you just want the DigitalRoot
+; Procedure.q DigitalRoot(N.q) apparently will do
+; i must have missed something because it seems too simple
+; http://en.wikipedia.org/wiki/Digital_root#Congruence_formula
+
+Procedure.q DigitalRoot(N.q)
+Protected M.q=N%9
+if M=0:ProcedureReturn 9
+Else  :ProcedureReturn M:EndIf
+EndProcedure
+
+; there appears to be a proof guarantying that Len(N$)<=1 for some X
+; http://en.wikipedia.org/wiki/Digital_root#Proof_that_a_constant_value_exists
+
+Procedure.s DigitalRootandPersistance(N.q)
+Protected r.s,t.s,X.q,M.q,persistance,N$=Str(N)
+M=DigitalRoot(N.q) ; just a test to see if we get the same DigitalRoot via the Congruence_formula
+
+Repeat
+X=0:Persistance+1
+
+For i=1 to Len(N$)       ; finding X as the sum of the digits of N
+X+Val(Mid(N$,i,1))
+Next
+
+N$=Str(X)
+If Len(N$)<=1:Break:EndIf ; If Len(N$)<=1:Break:EndIf
+Forever
+
+If Not (X-M)=0:t.s=" Error in my logic":else:t.s=" ok":EndIf
+
+r.s=RSet(Str(N),15)+" has additive persistance "+Str(Persistance)
+r.s+" and digital root of X(slow) ="+Str(X)+" M(fast) ="+Str(M)+t.s
+ProcedureReturn r.s
+EndProcedure
+
+NewList Nlist.q()
+AddElement(Nlist()) : Nlist()=627615
+AddElement(Nlist()) : Nlist()=39390
+AddElement(Nlist()) : Nlist()=588225
+AddElement(Nlist()) : Nlist()=393900588225
+
+FirstElement(Nlist())
+
+ForEach Nlist()
+N.q=Nlist()
+; cw(DigitalRootandPersistance(N))
+Debug DigitalRootandPersistance(N)
+Next

Task/Digital-root/Run-BASIC/digital-root.run

@@ -0,0 +1,23 @@
+print "Digital root of 627615       is "; digitRoot$(627615, 10)
+print "Digital root of 39390        is "; digitRoot$(39390, 10)
+print "Digital root of 588225       is "; digitRoot$(588225, 10)
+print "Digital root of 393900588225 is "; digitRoot$(393900588225, 10)
+print "Digital root of 9992         is "; digitRoot$(9992, 10)
+END
+
+function digitRoot$(n,b)
+WHILE n >= b
+  c = c + 1
+  n = digSum(n, b)
+wend
+digitRoot$ = n;" persistance is ";c
+end function
+
+function digSum(n, b)
+WHILE n <> 0
+  q = INT(n / b)
+  s = s + n - q * b
+  n = q
+wend
+digSum = s
+end function

Task/Digital-root/XPL0/digital-root.xpl0

@@ -0,0 +1,26 @@
+include c:\cxpl\codes;                  \intrinsic 'code' declarations
+
+func DRoot(N, B, P);                    \Return digital root and persistance P
+real N, B; int P;
+int  S;
+[P(0):= 0;
+while N >= B do
+        [S:= 0;
+        repeat  S:= S + fix(Mod(N,B));  \sum last digit
+                N:= N/B;                \remove last digit
+                N:= N - Mod(N,1.);
+        until   N < 0.1;                \(beware of rounding errors)
+        P(0):= P(0)+1;                  \increment persistance
+        N:= float(S);
+        ];
+return fix(N);
+];
+
+real Tbl;
+int  I, Root, Pers;
+[Tbl:= [627615., 39390., 588225., 393900588225.];
+for I:= 0 to 4-1 do
+        [Root:= DRoot(Tbl(I), 10., @Pers);
+        IntOut(0, Pers);  ChOut(0, ^ );  IntOut(0, Root);  CrLf(0);
+        ];
+]