/[dtapublic]/projs/ets/trunk/src/c_tclxtens_7_5/pr_randa.c
ViewVC logotype

Diff of /projs/ets/trunk/src/c_tclxtens_7_5/pr_randa.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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