~ubuntu-branches/ubuntu/raring/orpie/raring

« back to all changes in this revision

Viewing changes to mult.ml

  • Committer: Bazaar Package Importer
  • Author(s): Uwe Steinmann
  • Date: 2004-09-20 14:18:45 UTC
  • Revision ID: james.westby@ubuntu.com-20040920141845-j092sbrg4hd0nfsf
Tags: upstream-1.4.1
ImportĀ upstreamĀ versionĀ 1.4.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
 
1
(*  Orpie -- a stack-based RPN calculator for the console
 
2
 *  Copyright (C) 2003-2004  Paul Pelzl
 
3
 *
 
4
 *  This program is free software; you can redistribute it and/or modify
 
5
 *  it under the terms of the GNU General Public License as published by
 
6
 *  the Free Software Foundation; either version 2 of the License, or
 
7
 *  (at your option) any later version.
 
8
 *
 
9
 *  This program is distributed in the hope that it will be useful,
 
10
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 
11
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
12
 *  GNU General Public License for more details.
 
13
 *
 
14
 *  You should have received a copy of the GNU General Public License
 
15
 *  along with this program; if not, write to the Free Software
 
16
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
17
 *
 
18
 *  Please send bug reports, patches, etc. to Paul Pelzl at 
 
19
 *  <pelzlpj@eecs.umich.edu>.
 
20
 *)
 
21
 
 
22
open Rpc_stack
 
23
open Gsl_assist
 
24
open Big_int
 
25
 
 
26
let mult (stack : rpc_stack) (evaln : int -> unit) =
 
27
   evaln 2;
 
28
   let gen_el2 = stack#pop () in
 
29
   let gen_el1 = stack#pop () in
 
30
   match gen_el1 with
 
31
   |RpcInt el1 -> (
 
32
      match gen_el2 with
 
33
      |RpcInt el2 ->
 
34
         stack#push (RpcInt (mult_big_int el1 el2))
 
35
      |RpcFloatUnit el2 ->
 
36
         let fu_el1 = funit_of_float (float_of_big_int el1) in
 
37
         stack#push (RpcFloatUnit (Units.mult fu_el1 el2))
 
38
      |RpcComplexUnit el2 ->
 
39
         let cu_el1 = cunit_of_cpx (cmpx_of_int el1) in
 
40
         stack#push (RpcComplexUnit (Units.mult cu_el1 el2))
 
41
      |RpcFloatMatrixUnit (el2, uu) ->
 
42
         let result = Gsl_matrix.copy el2 in
 
43
         Gsl_matrix.scale result (float_of_big_int el1);
 
44
         stack#push (RpcFloatMatrixUnit (result, uu))
 
45
      |RpcComplexMatrixUnit (el2, uu) ->
 
46
         let c_el1 = cmpx_of_int el1 in
 
47
         let result = Gsl_matrix_complex.copy el2 in
 
48
         Gsl_matrix_complex.scale result c_el1;
 
49
         stack#push (RpcComplexMatrixUnit (result, uu))
 
50
      |_ ->
 
51
         (stack#push gen_el1;
 
52
         stack#push gen_el2;
 
53
         raise (Invalid_argument "incompatible types for multiplication"))
 
54
      )
 
55
   |RpcFloatUnit el1 -> (
 
56
      match gen_el2 with
 
57
      |RpcInt el2 ->
 
58
         let fu_el2 = funit_of_float (float_of_big_int el2) in
 
59
         stack#push (RpcFloatUnit (Units.mult el1 fu_el2))
 
60
      |RpcFloatUnit el2 ->
 
61
         stack#push (RpcFloatUnit (Units.mult el1 el2))
 
62
      |RpcComplexUnit el2 ->
 
63
         stack#push (RpcComplexUnit (Units.mult el1 el2))
 
64
      |RpcFloatMatrixUnit (el2, uu) ->
 
65
         let uprod = Units.mult el1 uu in
 
66
         let result = Gsl_matrix.copy el2 in
 
67
         Gsl_matrix.scale result uprod.Units.coeff.Complex.re;
 
68
         stack#push (RpcFloatMatrixUnit (result, unorm uprod))
 
69
      |RpcComplexMatrixUnit (el2, uu) ->
 
70
         let uprod = Units.mult el1 uu in
 
71
         let c_el1 = cmpx_of_float el1.Units.coeff.Complex.re in
 
72
         let result = Gsl_matrix_complex.copy el2 in
 
73
         Gsl_matrix_complex.scale result uprod.Units.coeff;
 
74
         stack#push (RpcComplexMatrixUnit (result, unorm uprod))
 
75
      |_ ->
 
76
         (stack#push gen_el1;
 
77
         stack#push gen_el2;
 
78
         raise (Invalid_argument "incompatible types for multiplication"))
 
79
      )
 
80
   |RpcComplexUnit el1 -> (
 
81
      match gen_el2 with
 
82
      |RpcInt el2 ->
 
83
         let cu_el2 = cunit_of_cpx (cmpx_of_int el2) in
 
84
         stack#push (RpcComplexUnit (Units.mult el1 cu_el2))
 
85
      |RpcFloatUnit el2 | RpcComplexUnit el2 ->
 
86
         stack#push (RpcComplexUnit (Units.mult el1 el2))
 
87
      |RpcFloatMatrixUnit (el2, u2) ->
 
88
         let uprod = Units.mult el1 u2 in
 
89
         let c_el2 = cmat_of_fmat el2 in
 
90
         Gsl_matrix_complex.scale c_el2 uprod.Units.coeff;
 
91
         stack#push (RpcComplexMatrixUnit (c_el2, unorm uprod))
 
92
      |RpcComplexMatrixUnit (el2, u2) ->
 
93
         let uprod = Units.mult el1 u2 in
 
94
         let result = Gsl_matrix_complex.copy el2 in
 
95
         Gsl_matrix_complex.scale result uprod.Units.coeff;
 
96
         stack#push (RpcComplexMatrixUnit (result, unorm uprod))
 
97
      |_ ->
 
98
         (stack#push gen_el1;
 
99
         stack#push gen_el2;
 
100
         raise (Invalid_argument "incompatible types for multiplication"))
 
101
      )
 
102
   |RpcFloatMatrixUnit (el1, u1) -> (
 
103
      match gen_el2 with
 
104
      |RpcInt el2 ->
 
105
         let result = Gsl_matrix.copy el1 in
 
106
         Gsl_matrix.scale result (float_of_big_int el2);
 
107
         stack#push (RpcFloatMatrixUnit (result, u1))
 
108
      |RpcFloatUnit el2 ->
 
109
         let uprod = Units.mult u1 el2 in
 
110
         let result = Gsl_matrix.copy el1 in
 
111
         Gsl_matrix.scale result uprod.Units.coeff.Complex.re;
 
112
         stack#push (RpcFloatMatrixUnit (result, unorm uprod))
 
113
      |RpcComplexUnit el2 ->
 
114
         let uprod = Units.mult u1 el2 in
 
115
         let c_el1 = cmat_of_fmat el1 in
 
116
         Gsl_matrix_complex.scale c_el1 uprod.Units.coeff;
 
117
         stack#push (RpcComplexMatrixUnit (c_el1, unorm uprod))
 
118
      |RpcFloatMatrixUnit (el2, u2) ->
 
119
         let n1, m1 = (Gsl_matrix.dims el1)
 
120
         and n2, m2 = (Gsl_matrix.dims el2) in
 
121
         if m1 = n2 then
 
122
            let uprod = Units.mult u1 u2 in
 
123
            let result = Gsl_matrix.create n1 m2 in
 
124
            Gsl_blas.gemm Gsl_blas.NoTrans Gsl_blas.NoTrans
 
125
            uprod.Units.coeff.Complex.re el1 el2 0.0 result;
 
126
            stack#push (RpcFloatMatrixUnit (result, unorm uprod))
 
127
         else
 
128
            (stack#push gen_el1;
 
129
            stack#push gen_el2;
 
130
            raise (Invalid_argument "incompatible matrix dimensions for multiplication"))
 
131
      |RpcComplexMatrixUnit (el2, u2) ->
 
132
         let n1, m1 = (Gsl_matrix.dims el1)
 
133
         and n2, m2 = (Gsl_matrix_complex.dims el2) in
 
134
         if m1 = n2 then
 
135
            let uprod = Units.mult u1 u2 in
 
136
            let c_el1 = cmat_of_fmat el1
 
137
            and result = Gsl_matrix_complex.create n1 m2 in
 
138
            Gsl_blas.Complex.gemm Gsl_blas.NoTrans Gsl_blas.NoTrans
 
139
            uprod.Units.coeff c_el1 el2 Complex.zero result;
 
140
            stack#push (RpcComplexMatrixUnit (result, unorm uprod))
 
141
         else
 
142
            (stack#push gen_el1; 
 
143
            stack#push gen_el2;
 
144
            raise (Invalid_argument "incompatible matrix dimensions for multiplication"))
 
145
      |_ ->
 
146
         (stack#push gen_el1;
 
147
         stack#push gen_el2;
 
148
         raise (Invalid_argument "incompatible types for multiplication"))
 
149
      )
 
150
   |RpcComplexMatrixUnit (el1, u1) -> (
 
151
      match gen_el2 with
 
152
      |RpcInt el2 ->
 
153
         let c_el2 = cmpx_of_int el2 in
 
154
         let result = Gsl_matrix_complex.copy el1 in
 
155
         Gsl_matrix_complex.scale result c_el2;
 
156
         stack#push (RpcComplexMatrixUnit (result, u1))
 
157
      |RpcFloatUnit el2 ->
 
158
         let uprod = Units.mult u1 el2 in
 
159
         let result = Gsl_matrix_complex.copy el1 in
 
160
         Gsl_matrix_complex.scale result uprod.Units.coeff;
 
161
         stack#push (RpcComplexMatrixUnit (result, unorm uprod))
 
162
      |RpcComplexUnit el2 ->
 
163
         let uprod = Units.mult u1 el2 in
 
164
         let result = Gsl_matrix_complex.copy el1 in
 
165
         Gsl_matrix_complex.scale result uprod.Units.coeff;
 
166
         stack#push (RpcComplexMatrixUnit (result, unorm uprod))
 
167
      |RpcFloatMatrixUnit (el2, u2) ->
 
168
         let n1, m1 = (Gsl_matrix_complex.dims el1)
 
169
         and n2, m2 = (Gsl_matrix.dims el2) in
 
170
         if m1 = n2 then
 
171
            let uprod = Units.mult u1 u2 in
 
172
            let c_el2 = cmat_of_fmat el2
 
173
            and result = Gsl_matrix_complex.create n1 m2 in
 
174
            Gsl_blas.Complex.gemm Gsl_blas.NoTrans Gsl_blas.NoTrans
 
175
            uprod.Units.coeff el1 c_el2 Complex.zero result;
 
176
            stack#push (RpcComplexMatrixUnit (result, unorm uprod))
 
177
         else
 
178
            (stack#push gen_el1;
 
179
            stack#push gen_el2;
 
180
            raise (Invalid_argument "incompatible matrix dimensions for multiplication"))
 
181
      |RpcComplexMatrixUnit (el2, u2) ->
 
182
         let n1, m1 = (Gsl_matrix_complex.dims el1)
 
183
         and n2, m2 = (Gsl_matrix_complex.dims el2) in
 
184
         if m1 = n2 then
 
185
            let uprod = Units.mult u1 u2 in
 
186
            let result = Gsl_matrix_complex.create n1 m2 in
 
187
            Gsl_blas.Complex.gemm Gsl_blas.NoTrans Gsl_blas.NoTrans
 
188
            uprod.Units.coeff el1 el2 Complex.zero result;
 
189
            stack#push (RpcComplexMatrixUnit (result, unorm uprod))
 
190
         else
 
191
            (stack#push gen_el1;
 
192
            stack#push gen_el2;
 
193
            raise (Invalid_argument "incompatible matrix dimensions for multiplication"))
 
194
      |_ ->
 
195
         (stack#push gen_el1;
 
196
         stack#push gen_el2;
 
197
         raise (Invalid_argument "incompatible types for multiplication"))
 
198
      )
 
199
   |_ ->
 
200
      (stack#push gen_el1;
 
201
      stack#push gen_el2;
 
202
      raise (Invalid_argument "incompatible types for multiplication"))
 
203
 
 
204
 
 
205
(* arch-tag: DO_NOT_CHANGE_5fc03e41-d1d3-40da-8b68-9a85d96148d0 *)