1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
2-- All rights reserved.
3--
4-- Redistribution and use in source and binary forms, with or without
5-- modification, are permitted provided that the following conditions are
6-- met:
7--
8--     - Redistributions of source code must retain the above copyright
9--       notice, this list of conditions and the following disclaimer.
10--
11--     - Redistributions in binary form must reproduce the above copyright
12--       notice, this list of conditions and the following disclaimer in
13--       the documentation and/or other materials provided with the
14--       distribution.
15--
16--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
17--       names of its contributors may be used to endorse or promote products
18--       derived from this software without specific prior written permission.
19--
20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31
32)package "BOOT"
33
34  -- HyperTeX basic Solve Command
35$systemType := nil
36$numberOfEquations := 0
37$solutionMethod := nil
38
39bcSolve() ==
40  htInitPage('"Solve Basic Command", nil)
41  htMakePage '(
42   (text . "What do you want to solve? ")
43   (text . "\beginmenu")
44   (text . "\item ")
45   (bcLinks ("\menuitemstyle{A System Of Linear Equations}" "" bcLinearSolve linear))
46   (text . "\item ")
47   (bcLinks ("\menuitemstyle{A System of Polynomial Equations}" "" bcSystemSolve  polynomial))
48   (text . "\item ")
49   (bcLinks ("\menuitemstyle{A Single Polynomial Equation}" "" bcSolveSingle onePolynomial))
50   (text . "\endmenu"))
51  htShowPage()
52
53bcLinearSolve(p,nn) ==
54  htInitPage('"Basic Solve Command", nil)
55  htMakePage '(
56    (text . "How do you want to enter the equations?")
57    (text . "\beginmenu")
58    (text . "\item ")
59    (text . "\newline ")
60    (bcLinks ("\menuitemstyle{Directly as equations}" "" bcLinearSolveEqns equations))
61    (text . "\item ")
62    (text . "\newline ")
63    (bcLinks ("\menuitemstyle{In matrix form}" "" bcLinearSolveMatrix matrix))
64    (text . "\indentrel{16}\tab{0}")
65    (text . " \spad{AX = B}, where \spad{A} is a matrix of coefficients and \spad{B} is a vector" )
66    (text . "\indentrel{-16}\item ")
67    (text . "\endmenu"))
68  htShowPage()
69
70bcLinearSolveEqns(htPage, p) ==
71  htInitPage('"Basic Solve Command", nil)
72  htMakePage '(
73    (domainConditions (isDomain PI (PositiveInteger)))
74    (inputStrings
75      ("Enter the {\em number} of equations:" "" 5 2 numberOfEquations PI)))
76  htMakeDoneButton('"Continue", 'bcLinearSolveEqns1)
77  htShowPage()
78
79bcSystemSolve(htPage, p) ==
80  htInitPage('"Basic Solve Command", nil)
81  htMakePage '(
82    (domainConditions (isDomain PI (PositiveInteger)))
83    (inputStrings
84      ("Enter the {\em number} of equations:" "" 5 2 numberOfEquations PI)))
85  htMakeDoneButton('"Continue", 'bcSystemSolveEqns1)
86  htShowPage()
87
88bcSolveSingle(htPage,p) ==
89  htpSetProperty(htPage,'systemType, 'onePolynomial)
90  htpSetProperty(htPage,'exitFunction,'bcInputSolveInfo)
91  bcInputEquations(htPage,'exact)
92
93bcSystemSolveEqns1 htPage ==
94  htpSetProperty(htPage,'systemType,'polynomial)
95  htpSetProperty(htPage,'exitFunction,'bcInputSolveInfo)
96  bcInputEquations(htPage,'exact)
97
98bcLinearSolveEqns1 htPage ==
99  htpSetProperty(htPage,'systemType,'linear)
100  htpSetProperty(htPage,'exitFunction,'bcLinearSolveEqnsGen)
101  bcInputEquations(htPage,'exact)
102
103bcInputSolveInfo htPage ==
104  page := htInitPage('"Solve Basic Command", htpPropertyList htPage)
105  htpSetProperty(page,'numberOfEquations,htpProperty(htPage,'numberOfEquations))
106  htpSetProperty(page,'inputArea,htpInputAreaAlist htPage)
107  htMakePage '(
108   (domainConditions (isDomain PI (PositiveInteger)))
109   (text . "What would you like?")
110   (text . "\beginmenu")
111   (text . "\item ")
112   (bcLinks ("\menuitemstyle{Exact Solutions}" "" bcSolveEquations exact))
113   (text . "\indentrel{18}\tab{0} ")
114   (text . "Solutions expressed in terms of {\em roots} of irreducible polynomials")
115   (text . "\indentrel{-18}")
116   (text . "\item ")
117   (bcLinks ("\menuitemstyle{Numeric Solutions}" "" bcSolveEquationsNumerically numeric))
118   (text . "\indentrel{18}\tab{0} ")
119   (text . "Solutions expressed in terms of approximate real or complex {\em numbers}")
120   (text . "\indentrel{-18}")
121   (text . "\item ")
122   (bcLinks ("\menuitemstyle{Radical Solutions}" "" bcSolveEquations radical))
123   (text . "\indentrel{18}\tab{0} ")
124   (text . "Solutions expressed in terms of {\em radicals} if it is possible")
125   (text . "\indentrel{-18}")
126   (text . "\endmenu"))
127  htShowPage()
128
129bcInputEquations(htPage,solutionMethod) ==
130  numEqs :=
131    htpProperty(htPage, 'systemType) = 'onePolynomial => 1
132    $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage,'numberOfEquations)
133    objValUnwrap htpLabelSpadValue(htPage, 'numberOfEquations)
134  linearPred := htpProperty(htPage,'systemType) = 'linear
135  labelList :=
136    numEqs = 1 => '(
137      (bcStrings (42 "x^2+1" l1 P))
138      (text . " = ")
139      (bcStrings (6 0 r1 P)))
140    "append"/[f(i,numEqs,linearPred) for i in 1..numEqs] where f(i,n,linearp) ==
141      spacer := (i > 99 => 0; i > 9 => 1; 2)
142      prefix := STRCONC('"\newline\tab{2}{\em Equation ",STRINGIMAGE i,'":}")
143      prefix := STRCONC(prefix,'"\space{",STRINGIMAGE spacer,'"}")
144      lnam := INTERN STRCONC('"l",STRINGIMAGE i)
145      rnam := INTERN STRCONC('"r",STRINGIMAGE i)
146      var:=
147        linearp => bcMakeLinearEquations(i,n)
148        bcMakeEquations(i,n)
149      [['text,:prefix],['bcStrings,[30,var,lnam,'P]],'(text . " = "),['bcStrings,[5,"0",rnam,'P]]]
150  equationPart := [
151     '(domainConditions
152        (isDomain P (Polynomial $EmptyMode))
153         (isDomain S (String))
154          (isDomain PI (PositiveInteger))),
155            :labelList]
156  page := htInitPage('"Solve Basic Command", htpPropertyList htPage)
157  htpSetProperty(page, 'numberOfEquations, numEqs)
158  htpSetProperty(page, 'solutionMethod,solutionMethod)
159  htSay '"\newline\menuitemstyle{}\tab{2}"
160  htSay
161    numEqs = 1 => '"Enter the {\em Equation}:"
162    '"Enter the {\em Equations}:"
163  htSay '"\newline\tab{2}"
164  htMakePage equationPart
165  bcHt '"\blankline "
166  htSay '"\newline\menuitemstyle{}\tab{2}"
167  htMakePage
168    numEqs = 1 =>  '(
169      (text ."Enter the {\em unknown} (leave blank if implied): ")
170      (text . "\tab{48}")
171      (bcStrings (6 "x" unknowns S . quoteString)))
172    ['(text . "Enter the unknowns (leave blank if implied):"),
173     '(text . "\tab{44}"),
174      ['bcStrings, [10,bcMakeUnknowns(numEqs),'unknowns,'P]]]
175  htMakeDoneButton('"Continue", 'bcInputEquationsEnd)
176  htShowPage()
177
178bcCreateVariableString(i) ==
179   STRCONC('"x",STRINGIMAGE i)
180
181bcMakeUnknowns(number)==
182   concatenateStringList([STRCONC(bcCreateVariableString(i)," ")
183                            for i in 1..number])
184
185bcMakeEquations(i,number)==
186   number =1 => STRCONC(bcCreateVariableString(1),"^2+1")
187   bcCreateVariableString(i)
188   STRCONC(
189     STRCONC(
190      concatenateStringList([STRCONC(bcCreateVariableString(j),"+")
191                               for j in 1..number]),"1"),
192        STRCONC("-2*",STRCONC(bcCreateVariableString(i),"^2")))
193
194
195bcMakeLinearEquations(i,number)==
196   number = 1 => bcCreateVariableString(1)
197   number = 2 =>
198        i=1 => STRCONC(bcCreateVariableString(1),STRCONC("+",bcCreateVariableString(2)))
199        STRCONC(bcCreateVariableString(1),STRCONC("-",bcCreateVariableString(2)))
200   STRCONC(
201     STRCONC(
202      concatenateStringList([STRCONC(bcCreateVariableString(j),"+")
203                               for j in 1..number]),"1"),
204        STRCONC("-2*",bcCreateVariableString(i)))
205
206
207bcInputEquationsEnd htPage ==
208  fun := htpProperty(htPage, 'exitFunction) => FUNCALL(fun,htPage)
209  systemError nil
210
211bcSolveEquationsNumerically(htPage,p) ==
212  page := htInitPage('"Solve Basic Command", htpPropertyList htPage)
213  htMakePage '(
214    (text . "What would you like?")
215    (radioButtons choice
216      ("Real roots expressed as rational numbers" "" rr)
217      ("Real roots expressed as floats" "" rf)
218      ("Complex roots expressed as rational numbers" "" cr)
219      ("Complex roots expressed as floats" "" cf))
220      (text . "\vspace{1}\newline")
221      (inputStrings
222        ("Enter the number of desired {\em digits} of accuracy" "" 5 20 acc PI)))
223  htMakeDoneButton('"Continue", 'bcSolveNumerically1)
224  htShowPage()
225
226bcSolveNumerically1(htPage) ==
227 bcSolveEquations(htPage,'numeric)
228
229--bcSolveNumerically1(htPage,kind) ==
230-- htpSetProperty(htPage,'kind,kind)
231-- bcSolveEquations(htPage,'numeric)
232
233bcSolveEquations(htPage,solutionMethod) ==
234  if solutionMethod = 'numeric then
235    digits := htpLabelInputString(htPage,'acc)
236    kind := htpButtonValue(htPage,'choice)
237    accString :=
238      kind in '(rf cf) => STRCONC('"1.e-",digits)
239      STRCONC('"1/10^",digits)
240  alist := htpProperty(htPage,'inputArea)
241  [[.,varpart,:.],:r] := alist
242  varlist := bcString2WordList varpart
243  varString := (rest varlist => bcwords2liststring varlist; first varlist)
244  eqnString := bcGenEquations r
245  solutionMethod = 'numeric =>
246    name :=
247      kind in '(rf rr) => '"solve"
248      '"complexSolve"
249    bcFinish(name,eqnString,accString)
250  name :=
251    solutionMethod = 'radical => '"radicalSolve"
252    '"solve"
253  bcFinish(name,eqnString,varString,accString)
254
255bcLinearSolveMatrix(htPage,junk) ==
256  bcReadMatrix 'bcLinearSolveMatrix1
257
258bcLinearSolveMatrix1 htPage ==
259  page := htInitPage('"Linear Solve Basic Command",htpPropertyList htPage)
260  htpSetProperty(page,'matrix,bcLinearExtractMatrix htPage)
261  htMakePage '(
262    (text . "The right side vector B is:")
263    (lispLinks
264      ("Zero:" "the system is homogeneous" bcLinearSolveMatrixHomo homo)
265      ("Not zero:" "the system is not homogeneous" bcLinearSolveMatrixInhomo nothomo)))
266  htShowPage()
267
268bcLinearExtractMatrix htPage == REVERSE htpInputAreaAlist htPage
269
270bcLinearSolveMatrixInhomo(htPage,junk) ==
271  nrows := htpProperty(htPage,'nrows)
272  ncols := htpProperty(htPage,'ncols)
273  labelList :=
274    [f(i) for i in 1..ncols] where f(i) ==
275      spacer := (i > 99 => 0; i > 9 => 1; 2)
276      prefix := STRCONC('"{\em Coefficient ",STRINGIMAGE i,'":}")
277      if spacer ~= 0 then
278        prefix := STRCONC(prefix,'"\space{",STRINGIMAGE spacer,'"}")
279      name := INTERN STRCONC('"c",STRINGIMAGE i)
280      [prefix,"",30, 0,name, 'P]
281  page := htInitPage('"Linear Solve Basic Command",htpPropertyList htPage)
282  htpSetProperty(page,'matrix,htpProperty(htPage,'matrix))
283  htpSetProperty(page,'nrows,nrows)
284  htpSetProperty(page,'ncols,ncols)
285  htMakePage [
286   '(domainConditions (isDomain P (Polynomial $EmptyMode))),
287    '(text . "Enter the right side vector B:"),
288        ['inputStrings, :labelList],
289          '(text . "\vspace{1}\newline Do you want:" ),
290             '(lispLinks
291                 ("All the solutions?" "" bcLinearSolveMatrixInhomoGen all)
292                  ("A particular solution?" "" bcLinearSolveMatrixInhomoGen particular))]
293  htShowPage()
294
295bcLinearSolveMatrixInhomoGen(htPage,key) ==  bcLinearMatrixGen(htPage,key)
296
297bcLinearSolveMatrixHomo(htPage,key) == bcLinearMatrixGen(htPage,'homo)
298
299bcLinearMatrixGen(htPage,key) ==
300  matform := bcMatrixGen htPage
301  key = 'homo => bcFinish('"nullSpace",matform)
302  vector := [x.1 for x in REVERSE htpInputAreaAlist htPage]
303  vecform := bcVectorGen vector
304  form := bcMkFunction('"solve",matform,[vecform])
305  bcGen
306    key = 'particular => STRCONC(form,'".particular")
307    form
308
309linearFinalRequest(nhh,mat,vect) ==
310  sayBrightly '"Do you want more information on the meaning of the output"
311  sayBrightly '"   (1) no "
312  sayBrightly '"   (2) yes "
313  tt := bcQueryInteger(1,2,true)
314  tt=1 => sayBrightly '"Bye Bye"
315  tt=2 => explainLinear(nhh)
316
317explainLinear(flag) ==
318  flag="notHomogeneous" =>
319   '("solve returns a particular solution and a basis for"
320     "the vector space of solutions for the homogeneous part."
321     "The particular solution is _"failed_" if one cannot be found.")
322  flag= "homogeneous" =>
323    '("solve returns a basis for"
324      "the vector space of solutions for the homogeneous part")
325  systemError nil
326
327finalExactRequest(equations,unknowns) ==
328  sayBrightly '"Do you like:"
329  sayBrightly '"   (1) the solutions how they are displayed"
330  sayBrightly '"   (2) to get ????"
331  sayBrightly '"   (3) more information on the meaning of the output"
332  tt := bcQueryInteger(1,3,true)
333  tt=1 => sayBrightly '"Bye Bye"
334  tt=2 => moreExactSolution(equations,unknowns,flag)
335  tt=3 => explainExact(equations,unknowns)
336
337bcLinearSolveEqnsGen htPage ==
338  alist := htpInputAreaAlist htPage
339  if vars := htpLabelInputString(htPage,'unknowns) then
340    varlist := bcString2WordList vars
341    varString := (rest varlist => bcwords2liststring varlist; first varlist)
342    alist := rest alist  --know these are first on the list
343  eqnString := bcGenEquations alist
344  bcFinish('"solve",eqnString,varString)
345
346bcGenEquations alist ==
347  y := alist
348  while y repeat
349    right := (first y).1
350    y := rest y
351    left := (first y).1
352    y := rest y
353    eqnlist := [STRCONC(left,'" = ",right),:eqnlist]
354  rest eqnlist => bcwords2liststring eqnlist
355  first eqnlist
356