shared_source/c_tclxtens_7_5/pr_randa.c

//$Header$
//-------------------------------------------------------------------------------------------------
//This file is part of "David T. Ashley's Shared Source Code", a set of shared components
//integrated into many of David T. Ashley's projects.
//-------------------------------------------------------------------------------------------------
//This source code and any program in which it is compiled/used is provided under the MIT License,
//reproduced below.
//-------------------------------------------------------------------------------------------------
//Permission is hereby granted, free of charge, to any person obtaining a copy of
//this software and associated documentation files(the "Software"), to deal in the
//Software without restriction, including without limitation the rights to use,
//copy, modify, merge, publish, distribute, sublicense, and / or sell copies of the
//Software, and to permit persons to whom the Software is furnished to do so,
//subject to the following conditions :
//
//The above copyright notice and this permission notice shall be included in all
//copies or substantial portions of the Software.
//
//THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
//IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
//FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.IN NO EVENT SHALL THE
//AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
//LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
//OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
//SOFTWARE.
//-------------------------------------------------------------------------------------------------
#define MODULE_PR_RANDA

#include "tcl.h"
#include "tcldecls.h"

#include "pr_randa.h"


/* Random seed used in this module.
*/
static unsigned long seed = 1578127215;


/* Returns the random successor of the argument.
** Uses the power residue method discussed
** in a probability book.  Is public so that other
** modules may use it.
*/
DECMOD_PR_RANDA unsigned long PrRandARandSucc(unsigned long arg)
   {
   __int64 k16807;
   __int64 input_arg;
   __int64 mul_result;
   __int64 return_value;
   __int64 M;

   k16807 = 16807;
   M = 2147483647;
   input_arg = arg;
   mul_result = k16807 * input_arg;
   return_value = mul_result % M;
   return((unsigned long)return_value);
   }


/* The command which requires the previous value to go on to
** the next.
*/
int PrRandA_rngPwrResRndA_cmd(ClientData dummy, 
                              Tcl_Interp *interp, 
                                   int objc, 
                                   Tcl_Obj *objv[]) 
   {
        int i;
      //Passed integer if one present.
        Tcl_Obj *rv;
      //Object to return.
   char *problem_arg;
      //String value of problem argument if we need to announce
      //it to caller.

   //We need to break this into three cases.  Either
   //there is one arg, which means use internal seed.
   //Or, there are two args, which means the predecessor
   //is supplied.  Or, there are more args, which means
   //error.
   if (objc == 1)
      {
      //Use internal seed.
      rv = Tcl_NewIntObj(seed);
      seed = PrRandARandSucc(seed);
      Tcl_SetObjResult(interp, rv);
      return(TCL_OK);
      }
   else if (objc == 2)
      {
      //Form successor of number passed.
      if (Tcl_GetIntFromObj(interp, objv[1], &i) != TCL_OK)
         {
         //We could not retrieve an integer from the passed argument.
         //We can't form the successor of a non-integer.
         //Error out.

         //Create the return object.
         rv = Tcl_NewStringObj("rngPwrResRndA: can't parse this argument as an integer: ", -1);

         //Tack on the offensive argument.
         problem_arg = Tcl_GetString(objv[1]);
         Tcl_AppendToObj(rv, problem_arg, -1);

         //Set the return value to be the error message.
         Tcl_SetObjResult(interp, rv);

         //Error return.
         return(TCL_ERROR);
         }

      rv = Tcl_NewIntObj(PrRandARandSucc(i));
      Tcl_SetObjResult(interp, rv);
      return(TCL_OK);
      }
   else //Wrong number of args.
      {
           Tcl_WrongNumArgs(interp, 
                       1, 
                       objv, 
                       "?N?");
      return(TCL_ERROR);
      }
   }


//Performs initial registration to the hash table.
//
DECMOD_PR_RANDA void PrRandAInit(Tcl_Interp *interp)
   {
   Tcl_CreateObjCommand(interp, 
                             "rngPwrResRndA",
                        (Tcl_ObjCmdProc *)PrRandA_rngPwrResRndA_cmd,
                                                 NULL,
                                                 NULL);
   }


DECMOD_PR_RANDA const char *PrRandACversion(void)
{   
    return ("$Header$");
}


DECMOD_PR_RANDA const char *PrRandAHversion(void)
{   
    return (PR_RANDA_H_VERSION);
}

/* End of pr_randa.c */
1	dashley	71	//$Header$
2			//-------------------------------------------------------------------------------------------------
3			//This file is part of "David T. Ashley's Shared Source Code", a set of shared components
4			//integrated into many of David T. Ashley's projects.
5			//-------------------------------------------------------------------------------------------------
6			//This source code and any program in which it is compiled/used is provided under the MIT License,
7			//reproduced below.
8			//-------------------------------------------------------------------------------------------------
9			//Permission is hereby granted, free of charge, to any person obtaining a copy of
10			//this software and associated documentation files(the "Software"), to deal in the
11			//Software without restriction, including without limitation the rights to use,
12			//copy, modify, merge, publish, distribute, sublicense, and / or sell copies of the
13			//Software, and to permit persons to whom the Software is furnished to do so,
14			//subject to the following conditions :
15			//
16			//The above copyright notice and this permission notice shall be included in all
17			//copies or substantial portions of the Software.
18			//
19			//THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
20			//IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
21			//FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.IN NO EVENT SHALL THE
22			//AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
23			//LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
24			//OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
25			//SOFTWARE.
26			//-------------------------------------------------------------------------------------------------
27			#define MODULE_PR_RANDA
28
29			#include "tcl.h"
30			#include "tcldecls.h"
31
32			#include "pr_randa.h"
33
34
35			/* Random seed used in this module.
36			*/
37			static unsigned long seed = 1578127215;
38
39
40			/* Returns the random successor of the argument.
41			** Uses the power residue method discussed
42			** in a probability book. Is public so that other
43			** modules may use it.
44			*/
45			DECMOD_PR_RANDA unsigned long PrRandARandSucc(unsigned long arg)
46			{
47			__int64 k16807;
48			__int64 input_arg;
49			__int64 mul_result;
50			__int64 return_value;
51			__int64 M;
52
53			k16807 = 16807;
54			M = 2147483647;
55			input_arg = arg;
56			mul_result = k16807 * input_arg;
57			return_value = mul_result % M;
58			return((unsigned long)return_value);
59			}
60
61
62			/* The command which requires the previous value to go on to
63			** the next.
64			*/
65			int PrRandA_rngPwrResRndA_cmd(ClientData dummy,
66			Tcl_Interp *interp,
67			int objc,
68			Tcl_Obj *objv[])
69			{
70			int i;
71			//Passed integer if one present.
72			Tcl_Obj *rv;
73			//Object to return.
74			char *problem_arg;
75			//String value of problem argument if we need to announce
76			//it to caller.
77
78			//We need to break this into three cases. Either
79			//there is one arg, which means use internal seed.
80			//Or, there are two args, which means the predecessor
81			//is supplied. Or, there are more args, which means
82			//error.
83			if (objc == 1)
84			{
85			//Use internal seed.
86			rv = Tcl_NewIntObj(seed);
87			seed = PrRandARandSucc(seed);
88			Tcl_SetObjResult(interp, rv);
89			return(TCL_OK);
90			}
91			else if (objc == 2)
92			{
93			//Form successor of number passed.
94			if (Tcl_GetIntFromObj(interp, objv[1], &i) != TCL_OK)
95			{
96			//We could not retrieve an integer from the passed argument.
97			//We can't form the successor of a non-integer.
98			//Error out.
99
100			//Create the return object.
101			rv = Tcl_NewStringObj("rngPwrResRndA: can't parse this argument as an integer: ", -1);
102
103			//Tack on the offensive argument.
104			problem_arg = Tcl_GetString(objv[1]);
105			Tcl_AppendToObj(rv, problem_arg, -1);
106
107			//Set the return value to be the error message.
108			Tcl_SetObjResult(interp, rv);
109
110			//Error return.
111			return(TCL_ERROR);
112			}
113
114			rv = Tcl_NewIntObj(PrRandARandSucc(i));
115			Tcl_SetObjResult(interp, rv);
116			return(TCL_OK);
117			}
118			else //Wrong number of args.
119			{
120			Tcl_WrongNumArgs(interp,
121			1,
122			objv,
123			"?N?");
124			return(TCL_ERROR);
125			}
126			}
127
128
129			//Performs initial registration to the hash table.
130			//
131			DECMOD_PR_RANDA void PrRandAInit(Tcl_Interp *interp)
132			{
133			Tcl_CreateObjCommand(interp,
134			"rngPwrResRndA",
135			(Tcl_ObjCmdProc *)PrRandA_rngPwrResRndA_cmd,
136			NULL,
137			NULL);
138			}
139
140
141			DECMOD_PR_RANDA const char *PrRandACversion(void)
142			{
143			return ("$Header$");
144			}
145
146
147			DECMOD_PR_RANDA const char *PrRandAHversion(void)
148			{
149			return (PR_RANDA_H_VERSION);
150			}
151
152			/* End of pr_randa.c */