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	//$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 */