retroforth/example/minimize.retro
crc ee87d47b0e add minimize.retro to examples (thanks kiyoshi)
FossilOrigin-Name: d6be3a03ffb2e27f9af40079e3ebbd7f7fc1099883ad9a3ec0785b7be520b809
2020-01-02 15:29:48 +00:00

158 lines
4.2 KiB
Text

# Single variable function minimizer
The function must be continuous unimodal,
taking a floating point argument and returning a floating point value.
The method is binary search based on the derivative at the splitting point.
Convergence is judged by the change in function value.
First, words defined elsewhere.
~~~
{{
:d:another-name (as-)
d:create &class:word reclass d:last d:xt swap d:xt fetch swap store ;
---reveal---
:d:aka (s-)_Also-Known-As,_make_alias_of_the_last_defined_word
[ d:last ] dip d:another-name ; 'aka d:aka
:d:alias (ss-)_make_alias_s2_of_s1
[ d:lookup ] dip d:another-name ; 'alias d:aka
}}
'var<n> 'var! (n-) alias
'lt? 'n:<? alias
'lteq? 'n:=<? alias
:v:put (a-) fetch n:put ;
:e:fetch (a-__-f)_fetch_as_float fetch e:to-f ; 'e:@ aka
:e:store (a-__f-)_store_as_e f:to-e swap store ; 'e:! aka
:e:call.vv (aaa-)_call_floating_point_function_variable-to-variable
rot e:@ (aa_n) call (a_n) e:! ;
:s:shout (s-) '!_%s s:format s:put ;
{{
'Depth var
:message (-)
'abort_with__trail__invoked s:shout nl
'Do__reset__to_clear_stack. s:put nl ;
:put-name (a-) fetch d:lookup-xt
dup n:-zero? [ d:name s:put nl ] [ drop ] choose ;
---reveal---
:trail repeat pop put-name again ;
:abort (-0) depth !Depth message trail ;
:s:abort (s-0) 's:abort_:_ s:prepend s:put nl abort ;
}}
:assert (q-) call [ abort ] -if ;
:assert.verbous (q-) call [ 'assert_:_fail s:abort ] -if ;
:dump-stacks (-) dump-stack
#0 f:depth lt? [ nl 'f_ s:put f:dump-stack ] if
#0 f:adepth lt? [ nl 'fa_ s:put f:dump-astack ] if ; '. aka
~~~
Program.
~~~
{{
(input_variables
'F var (Function_to_minimize_(-_n-n)_float_to_float
'L var (e:low
'H var (e:high
TRUE 'Tr var! (trace_flag
.0.000001 f:to-e 'TOL const (=173=tolerance
#30 'ITMAX const (max_#_of_iterations
(working_variables
'Ly var (e:low-value
'Hy var
'X1y var (y_at_upper_next_to_x
'Y var (function_value_at_X
'Itr var (iterations
(output_variable
'X var (candidate
:trace (-) @Tr [ ( Itr v:put sp )
( @L e:put sp ) ( @X e:put sp ) ( @H e:put sp ) nl ] if ;
:y (-) X Y @F e:call.vv ;
:x (-)_(L_H_->_X) @L @H + #2 / !X ;
:x1y (-) @X n:inc e:to-f @F call X1y e:! ;
---reveal---
:minimize (a-_nn-x)_(L_H_F_->_X)
(minimize_floating_point_function_F_over_[L,H]
(initialize ( !F f:to-e !H f:to-e !L )
( L Ly @F e:call.vv ) ( H Hy @F e:call.vv ) x y ( #0 !Itr )
[ trace x1y
( @Y @X1y n:<? ) [ @X !H @Y !Hy ] [ @X !L @Y !Ly ] choose
x y Itr v:inc [ @Itr ITMAX n:=<? ] assert.verbous
TOL @Y @X1y - n:abs n:<? ] while X e:@ ;
}}
~~~
```
:f (-_x-y)_(x-2)^2 .2. f:- f:dup f:* ;
.-3 .10 &f minimize . nl
```
```
:f (-_x-y) f:abs ;
.-5. .5 &f minimize . nl
```
Note how `x` is defined without conversios as
:x (-)_(L_H_->_X) @L @H + 2 / !X ;
rather than
:x (-)_(L_H_->_X) ( L e:@ ) ( H e:@ ) f:+ .2. f:/ X e:! ;
Doing
```
:f (-_x-y) ;
.0 .5 &f minimize . nl
```
with the first definition gives
# low mid high
0 0.000000 1.249991 5.000009
1 0.000000 0.312492 1.249991
2 0.000000 0.078120 0.312492
3 0.000000 0.019530 0.078120
4 0.000000 0.004882 0.019530
5 0.000000 0.001220 0.004882
6 0.000000 0.000305 0.001220
7 0.000000 0.000076 0.000305
8 0.000000 0.000019 0.000076
9 0.000000 0.000005 0.000019
10 0.000000 0.000001 0.000005
final x = 0.000000
whereas with the second definition gives
# low mid high
0 0.000000 2.500004 5.000009
1 0.000000 1.249991 2.500004
2 0.000000 0.625001 1.249991
3 0.000000 0.312503 0.625001
4 0.000000 0.156254 0.312503
5 0.000000 0.078126 0.156254
6 0.000000 0.039062 0.078126
7 0.000000 0.019530 0.039062
8 0.000000 0.009765 0.019530
9 0.000000 0.004883 0.009765
10 0.000000 0.002441 0.004883
11 0.000000 0.001221 0.002441
12 0.000000 0.000611 0.001221
13 0.000000 0.000305 0.000611
14 0.000000 0.000153 0.000305
15 0.000000 0.000076 0.000153
16 0.000000 0.000038 0.000076
17 0.000000 0.000019 0.000038
18 0.000000 0.000009 0.000019
final x = 0.000005