;--------------------------------------------------------------------
; RSC-REPOSITORY                                               GET/97
;--------------------------------------------------------------------
;                  Copyright@1996 by F. Luis Neves
;
; Author(s):       FLN (F. Luis Neves)
; Revisions:       24.Mar.96 Rev:  8 May, 1996
;                            Rev:  5 Dec, 1996
;                            Rev: 10 Dec, 1996 (variable size c.)
;                            Rev:  2 Apr, 1997 (partial populations)
;                            Rev:  3 Jan, 1998 (final revisions)
;                            Rev:  8 Jan, 1998 (RPrb and CPrb added)
;                            Rev:  9 Jan, 1998 (2p-crossover added)
;                            Rev: 10 Jan, 1998 (best survives added)
;                            Rev: 10 Jan, 1998 (unif-crossover added)
;                            Rev: 21 Jan, 1998 (decimal-list genes)
;                                   
;--------------------------------------------------------------------
;
; Comments: GEnetic algorithms Tool
; 
; (a) Filiation: GET < FDEP
; (b) Interface:
;                        -----------
;                       |           |
;                       |           |
;             INIT ---> |           | EMPTY:Bool --->
;                       |           |
;         INS(A,B) ---> |    GET    |
;                       |           |
;       <--- SEL(A,I):B |           | <--- REM(A)
;                       |           |
;                       |           |
;                        -----------
;
; (c) State: S = A -> B
; (d) Model:
;
;--------------------------------------------------------------------
; Note: If I = {1,2,...} then B = B1:... B2:... B_:...;

( load "int.met" )
;---------------------
; PV = CS (Chromsize)              x
;      PS (Population Size)        x
;      SS (Segment Size)           x  (for binary representation only)
;      PC (Probability-Crossover)  x
;      PU (Probability-UCrossover) x
;      PM (Probability-Mutation)   x
;      VC (Variable Size Chrom.)   x
;      CT (Crossover type)         x
;      BS (Best survives)          x
;      GR (Gene Representation)    x  GR = 0 (binary),
;                                     GR = 1 (decimal)
;                                     GR = 2 (decimal-list)
;      MV (Maximum Gene Value)        for decimal representation only
; PP = ID (Individual) -> C (Chromossome) x F (Fitness) x S (Chrom.Size)
;                                         x RP (Relative Probability)
;                                         x CP (Cumulative Probability)

( deftype G FF I R )
;---------------------

( deftype I INT )
;---------------------

( deftype R TUP
  ( B1 LIST Gene )
  ( B2 Fit )
  ( B3 CSize )
  ( B4 RProb )
  ( B5 CProb )
)
;---------------------

( deftype P TUP
  ( CS CSize )
  ( PS PSize )
  ( SS SSize )
  ( PC PCVal )
  ( PU PUVal )
  ( PM PMVal )
  ( VC VSize )
  ( CT CType )
  ( BS BSurv )
  ( GR GRepr )
  ( MV MGVal )
)
;---------------------

( deftype Fit INT )
;---------------------

( deftype Gene ALT INT LIST INT )
;---------------------

( deftype RProb INT )
;---------------------

( deftype CProb INT )
;---------------------

( deftype CSize INT )
;---------------------

( deftype PSize INT )
;---------------------

( deftype SSize INT )
;---------------------

( deftype PCVal INT )
;---------------------

( deftype PUVal INT )
;---------------------

( deftype PMVal INT )
;---------------------

( deftype VSize SYM )
;---------------------

( deftype CType INT )
;---------------------

( deftype BSurv SYM )
;---------------------

( deftype GRepr INT )
;---------------------

( deftype MGVal INT )
;---------------------
;--------------------------------------------------------------------
; Note: If I = {1,2,...} then SEL(a,1) = B1(S[a]); SEL(a,2) = B2(S[a]); ...

( def _ops
  ( plus _ops
    ( makeff
      (
        ( quote gpINIT )
        ( quote
          (
            ( )
            ( Void )
          )
        )
      )
    )
  )
)
;---------------------

( def gpINIT lambda
  ( )
  ( def G
    ( makeff )
  )
)
;---------------------

( def _ops
  ( plus _ops
    ( makeff
      (
        ( quote gpINS )
        ( quote
          (
            (
              ( I )
              ( R )
            )
            ( Void )
          )
        )
      )
    )
  )
)
;---------------------

( def gpINS lambda
  ( a b )
  ( if
    ( not
      ( member a
        ( dom G )
      )
    )
    ( def G
      ( plus G
        ( makeff
          ( a b )
        )
      )
    )
    ( strcat "ERROR (precondition violated) in function " "gpINS" )
  )
)
;---------------------

( def _ops
  ( plus _ops
    ( makeff
      (
        ( quote gpREM )
        ( quote
          (
            (
              ( I )
            )
            ( Void )
          )
        )
      )
    )
  )
)
;---------------------

( def gpREM lambda
  ( a )
  ( def G
    ( ds G
      ( makeset a )
    )
  )
)
;---------------------

( def _ops
  ( plus _ops
    ( makeff
      (
        ( quote gpSEL )
        ( quote
          (
            (
              ( I )
              ( INT )
            )
            ( R )
          )
        )
      )
    )
  )
)
;---------------------

( def gpSEL lambda
  ( a i )
  ( if
    ( member a
      ( dom G )
    )
    ( cond
      (
        ( equal i 1 )
        ( p1
          ( ap G a )
        )
      )
      (
        ( equal i 2 )
        ( p2
          ( ap G a )
        )
      )
      (
        ( equal i 3 )
        ( p3
          ( ap G a )
        )
      )
      (
        ( equal i 4 )
        ( p4
          ( ap G a )
        )
      )
      (
        ( equal i 5 )
        ( p5
          ( ap G a )
        )
      )
    )
    ( strcat "ERROR (precondition violated) in function " "gpSEL" )
  )
)
;---------------------

( def _ops
  ( plus _ops
    ( makeff
      (
        ( quote gpEMPTY )
        ( quote
          (
            ( )
            ( Bool )
          )
        )
      )
    )
  )
)
;---------------------

( def gpEMPTY lambda
  ( )
  ( equal G
    ( makeff )
  )
)
;---------------------
;--------------------------------------------------------------------
; Genetic Programming auxiliary functions

( def _ops
  ( plus _ops
    ( makeff
      (
        ( quote perc )
        ( quote
          (
            (
              ( INT )
              ( INT )
            )
            ( INT )
          )
        )
      )
    )
  )
)
;---------------------

( def perc lambda
  ( a b )
  ( if
    ( nequal b 0 )
    ( cond
      (
        ( lt a 32 )
        ( div
          ( div
            ( mul a 1000 ) b
          ) 10
        )
      )
      (
        ( lt a 64 )
        ( div
          ( div
            ( mul a 500 ) b
          ) 5
        )
      )
      (
        ( lt a 160 )
        ( div
          ( div
            ( mul a 200 ) b
          ) 2
        )
      )
      (
        ( lt a 320 )
        ( div
          ( mul a 100 ) b
        )
      )
      (
        ( lt a 640 )
        ( mul
          ( div
            ( mul a 50 ) b
          ) 2
        )
      )
      (
        ( lt a 1280 )
        ( mul
          ( div
            ( mul a 25 ) b
          ) 4
        )
      )
      ( true
        ( mul
          ( div a b ) 100
        )
      )
    ) 0
  )
)
;---------------------

( def _ops
  ( plus _ops
    ( makeff
      (
        ( quote prob )
        ( quote
          (
            (
              ( INT )
              ( INT )
            )
            ( SYM )
          )
        )
      )
    )
  )
)
;---------------------

( def prob lambda
  ( i j )
  ( lt
    ( rand j ) i
  )
)
;---------------------

( def _ops
  ( plus _ops
    ( makeff
      (
        ( quote rand2 )
        ( quote
          (
            (
              ( INT )
              ( INT )
            )
            ( INT )
          )
        )
      )
    )
  )
)
;---------------------

( def rand2 lambda
  ( i j )
  ( add
    ( rand
      ( add
        ( sub j i ) 1
      )
    ) i
  )
)
;---------------------

( def _ops
  ( plus _ops
    ( makeff
      (
        ( quote rchoice )
        ( quote
          (
            (
              ( SET ANY )
            )
            ( ANY )
          )
        )
      )
    )
  )
)
;---------------------

( def rchoice lambda
  ( s )
  ( if
    ( nequal s
      ( makeset )
    )
    ( nth
      ( add
        ( rand
          ( card s )
        ) 1
      )
      ( seq x
        ( from x s )
      )
    )
    ( strcat "ERROR (precondition violated) in function " "rchoice" )
  )
)
;---------------------

( def rcprob lambda
  ( s )
  ( let
    (
      ( tf
        ( reduce 0 add
          ( set
            ( p2
              ( ap s k )
            )
            ( from k
              ( dom s )
            )
          )
        )
      )
    )
    ( _rcprob_ s tf 0 )
  )
)
;---------------------

( def _rcprob_ lambda
  ( s tf cf )
  ( if
    ( equal s
      ( makeff )
    )
    ( makeff )
    ( let
      (
        ( x
          ( choice
            ( dom s )
          )
        )
        ( y
          ( ap s x )
        )
        ( cx
          ( p1 y )
        )
        ( fx
          ( p2 y )
        )
        ( sx
          ( p3 y )
        )
        ( rfx
          ( perc fx tf )
        )
        ( cfx
          ( add cf rfx )
        )
      )
      ( plus
        ( makeff
          ( x
            ( R cx fx sx rfx cfx )
          )
        )
        ( _rcprob_
          ( ds s
            ( makeset x )
          ) tf cfx
        )
      )
    )
  )
)
;---------------------
;
; One-point crossover for variable size chromosomes
;

( def vcrossover lambda
  ( s i )
  ( if
    ( gt i
      ( PS GV )
    )
    ( makeff )
    ( if
      ( prob
        ( PC GV ) 100
      )
      ( plus
        ( _vcross_ s i )
        ( vcrossover s
          ( add i 2 )
        )
      )
      ( plus
        ( _ncross_ s i )
        ( vcrossover s
          ( add i 1 )
        )
      )
    )
  )
)
;---------------------

( def _vcross_ lambda
  ( s k )
  ( let
    (
      ( x
        ( rchoice
          ( dom s )
        )
      )
      ( y
        ( rchoice
          ( dom s )
        )
      )
      ( sx
        ( gpSEL x 3 )
      )
      ( sy
        ( gpSEL y 3 )
      )
      ( cp
        ( if
          ( lt sx sy )
          ( rand sx )
          ( rand sy )
        )
      )
      ( cx
        ( gpSEL x 1 )
      )
      ( cy
        ( gpSEL y 1 )
      )
      ( nx
        ( append
          ( seq
            ( nth i cx )
            ( from i
              ( inseg cp )
            )
          )
          ( seq
            ( nth i cy )
            ( from i
              ( set j
                ( from j
                  ( inseg sy )
                  ( gt j cp )
                )
              )
            )
          )
        )
      )
      ( ny
        ( append
          ( seq
            ( nth i cy )
            ( from i
              ( inseg cp )
            )
          )
          ( seq
            ( nth i cx )
            ( from i
              ( set j
                ( from j
                  ( inseg sx )
                  ( gt j cp )
                )
              )
            )
          )
        )
      )
      ( fx
        ( gpSEL x 2 )
      )
      ( fy
        ( gpSEL y 2 )
      )
      ( rfx
        ( gpSEL x 4 )
      )
      ( rfy
        ( gpSEL y 4 )
      )
      ( cfx
        ( gpSEL x 5 )
      )
      ( cfy
        ( gpSEL y 5 )
      )
    )
    ( makeff
      ( k
        ( R nx fx sy rfx cfx )
      )
      (
        ( add k 1 )
        ( R ny fy sx rfy cfy )
      )
    )
  )
)
;---------------------
;
; To be replaced by the specific evaluation function...
;

( def _evalf_ lambda
  ( c )
  ( if
    ( equal c
      ( makeseq )
    ) 0
    ( intSUM c )
  )
)
;---------------------
;_evalf_(c) = if c == <> then 0
;             else let (h = head(c),t = tail(c))
;                  in if (h == 1) then 1 .+ _evalf_(t)
;                     else _evalf_(t);
;_evalf_(c) = _eval2_(c,1);

( def _eval2_ lambda
  ( c i )
  ( if
    ( equal c
      ( makeseq )
    ) 0
    ( let
      (
        ( h
          ( hd c )
        )
        ( t
          ( tl c )
        )
      )
      ( add
        ( add
          ( div h i )
          ( rem h i )
        )
        ( _eval2_ t
          ( add i 1 )
        )
      )
    )
  )
)
;---------------------
;--------------------------------------------------------------------
; Genetic Programming main functions
;
; Default parameters
;

( def GV
  ( P 10 10 1 25 60 10 false 1 true 1 37 )
)
;---------------------

( def _ops
  ( plus _ops
    ( makeff
      (
        ( quote gpSTART )
        ( quote
          (
            ( ) NIL
          )
        )
      )
    )
  )
)
;---------------------

( def gpSTART lambda
  ( )
  ( progn
    ( gpINIT )
    ( cond
      (
        ( equal
          ( GR GV ) 0
        )
        ( _start0_ )
      )
      (
        ( equal
          ( GR GV ) 1
        )
        ( _start1_ )
      )
      (
        ( equal
          ( GR GV ) 2
        )
        ( _start2_ )
      )
    )
  )
)
;---------------------

( def _start0_ lambda
  ( )
  ( if
    ( not
      ( VC GV )
    )
    ( foreach k
      ( inseg
        ( PS GV )
      )
      ( let
        (
          ( b
            ( R
              ( seq
                ( rem
                  ( rand i ) 2
                )
                ( from i
                  ( inseg
                    ( CS GV )
                  )
                )
              ) 0 0 0 0
            )
          )
        )
        ( gpINS k b )
      )
    )
    ( foreach k
      ( inseg
        ( PS GV )
      )
      ( let
        (
          ( r
            ( rand
              ( CS GV )
            )
          )
          ( b
            ( R
              ( seq
                ( rem
                  ( rand i ) 2
                )
                ( from i
                  ( inseg r )
                )
              ) 0 0 0 0
            )
          )
        )
        ( gpINS k b )
      )
    )
  )
)
;---------------------

( def _start1_ lambda
  ( )
  ( if
    ( not
      ( VC GV )
    )
    ( foreach k
      ( inseg
        ( PS GV )
      )
      ( let
        (
          ( b
            ( R
              ( seq
                ( rand
                  ( MV GV )
                )
                ( from i
                  ( inseg
                    ( CS GV )
                  )
                )
              ) 0 0 0 0
            )
          )
        )
        ( gpINS k b )
      )
    )
    ( foreach k
      ( inseg
        ( PS GV )
      )
      ( let
        (
          ( r
            ( rand
              ( CS GV )
            )
          )
          ( b
            ( R
              ( seq
                ( rand
                  ( MV GV )
                )
                ( from i
                  ( inseg r )
                )
              ) 0 r 0 0
            )
          )
        )
        ( gpINS k b )
      )
    )
  )
)
;---------------------

( def _start2_ lambda
  ( )
  ( if
    ( not
      ( VC GV )
    )
    ( foreach k
      ( inseg
        ( PS GV )
      )
      ( let
        (
          ( b
            ( R
              ( seq
                ( seq
                  ( rand
                    ( MV GV )
                  )
                  ( from j
                    ( inseg
                      ( SS GV )
                    )
                  )
                )
                ( from i
                  ( inseg
                    ( CS GV )
                  )
                )
              ) 0 0 0 0
            )
          )
        )
        ( gpINS k b )
      )
    )
    ( foreach k
      ( inseg
        ( PS GV )
      )
      ( let
        (
          ( r
            ( rand
              ( CS GV )
            )
          )
          ( b
            ( R
              ( seq
                ( seq
                  ( rand
                    ( MV GV )
                  )
                  ( from j
                    ( inseg
                      ( SS GV )
                    )
                  )
                )
                ( from i
                  ( inseg r )
                )
              ) 0 r 0 0
            )
          )
        )
        ( gpINS k b )
      )
    )
  )
)
;---------------------

( def _ops
  ( plus _ops
    ( makeff
      (
        ( quote gpPSTART )
        ( quote
          (
            (
              ( SET INT )
            ) NIL
          )
        )
      )
    )
  )
)
;---------------------

( def gpPSTART lambda
  ( s )
  ( if
    ( or
      ( equal
        ( GR GV ) 1
      )
      ( equal
        ( GR GV ) 2
      )
    )
    ( progn
      ( gpINIT )
      ( cond
        (
          ( equal
            ( GR GV ) 1
          )
          ( _pstart1_ s )
        )
        (
          ( equal
            ( GR GV ) 2
          )
          ( _pstart2_ s )
        )
      )
    )
    ( strcat "ERROR (precondition violated) in function " "gpPSTART" )
  )
)
;---------------------

( def _pstart1_ lambda
  ( s )
  ( if
    ( not
      ( VC GV )
    )
    ( foreach k
      ( inseg
        ( PS GV )
      )
      ( let
        (
          ( b
            ( R
              ( seq
                ( rchoice s )
                ( from i
                  ( inseg
                    ( CS GV )
                  )
                )
              ) 0 0 0 0
            )
          )
        )
        ( gpINS k b )
      )
    )
    ( foreach k
      ( inseg
        ( PS GV )
      )
      ( let
        (
          ( r
            ( rand
              ( CS GV )
            )
          )
          ( b
            ( R
              ( seq
                ( rchoice s )
                ( from i
                  ( inseg r )
                )
              ) 0 r 0 0
            )
          )
        )
        ( gpINS k b )
      )
    )
  )
)
;---------------------

( def _pstart2_ lambda
  ( s )
  ( if
    ( not
      ( VC GV )
    )
    ( foreach k
      ( inseg
        ( PS GV )
      )
      ( let
        (
          ( b
            ( R
              ( seq
                ( seq
                  ( rchoice s )
                  ( from j
                    ( inseg
                      ( SS GV )
                    )
                  )
                )
                ( from i
                  ( inseg
                    ( CS GV )
                  )
                )
              ) 0 0 0 0
            )
          )
        )
        ( gpINS k b )
      )
    )
    ( foreach k
      ( inseg
        ( PS GV )
      )
      ( let
        (
          ( r
            ( rand
              ( CS GV )
            )
          )
          ( b
            ( R
              ( seq
                ( seq
                  ( rchoice s )
                  ( from j
                    ( inseg
                      ( SS GV )
                    )
                  )
                )
                ( from i
                  ( inseg r )
                )
              ) 0 r 0 0
            )
          )
        )
        ( gpINS k b )
      )
    )
  )
)
;---------------------

( def _ops
  ( plus _ops
    ( makeff
      (
        ( quote gpSELECT )
        ( quote
          (
            ( ) NIL
          )
        )
      )
    )
  )
)
;---------------------

( def gpSELECT lambda
  ( )
  ( def G
    ( let
      (
        ( t
          ( intMAX
            ( set
              ( p5
                ( ap G x )
              )
              ( from x
                ( dom G )
              )
            )
          )
        )
      )
      ( if
        ( BS GV )
        ( let
          (
            ( b
              ( gpBEST )
            )
            ( x
              ( choice
                ( dom b )
              )
            )
          )
          ( plus
            ( makeff
              ( 1
                ( ap b x )
              )
            )
            ( _roleta_ G 2 t )
          )
        )
        ( _roleta_ G 1 t )
      )
    )
  )
)
;---------------------

( def _roleta_ lambda
  ( s n t )
  ( if
    ( gt n
      ( PS GV )
    )
    ( makeff )
    ( plus
      ( _select_ s n
        ( rand t )
      )
      ( _roleta_ s
        ( add n 1 ) t
      )
    )
  )
)
;---------------------

( def _select_ lambda
  ( s i p )
  ( if
    ( equal s
      ( makeff )
    )
    ( makeff )
    ( let
      (
        ( x
          ( choice
            ( dom s )
          )
        )
        ( y
          ( ap s x )
        )
        ( cx
          ( p1 y )
        )
        ( fx
          ( p2 y )
        )
        ( sx
          ( p3 y )
        )
        ( rfx
          ( p4 y )
        )
        ( cfx
          ( p5 y )
        )
      )
      ( if
        ( gt p cfx )
        ( _select_
          ( ds s
            ( makeset x )
          ) i p
        )
        ( makeff
          ( i
            ( R cx fx sx rfx cfx )
          )
        )
      )
    )
  )
)
;---------------------

( def _ops
  ( plus _ops
    ( makeff
      (
        ( quote gpCROSSOVER )
        ( quote
          (
            ( ) NIL
          )
        )
      )
    )
  )
)
;---------------------

( def gpCROSSOVER lambda
  ( )
  ( if
    ( BS GV )
    ( let
      (
        ( b
          ( gpBEST )
        )
        ( x
          ( choice
            ( dom b )
          )
        )
        ( o
          ( cond
            (
              ( equal
                ( CT GV ) 1
              )
              ( crossover1 G 2 )
            )
            (
              ( equal
                ( CT GV ) 2
              )
              ( crossover2 G 2 )
            )
            (
              ( equal
                ( CT GV ) 3
              )
              ( ucrossover G 2 )
            )
          )
        )
        ( p
          ( if
            ( equal
              ( card
                ( dom o )
              )
              ( PS GV )
            )
            ( ds o
              ( makeset
                ( rchoice
                  ( dom o )
                )
              )
            ) o
          )
        )
      )
      ( def G
        ( plus
          ( makeff
            ( 1
              ( ap b x )
            )
          ) p
        )
      )
    )
    ( let
      (
        ( o
          ( cond
            (
              ( equal
                ( CT GV ) 1
              )
              ( crossover1 G 1 )
            )
            (
              ( equal
                ( CT GV ) 2
              )
              ( crossover2 G 1 )
            )
            (
              ( equal
                ( CT GV ) 3
              )
              ( ucrossover G 1 )
            )
          )
        )
        ( p
          ( if
            ( equal
              ( card
                ( dom o )
              )
              ( PS GV )
            ) o
            ( ds o
              ( makeset
                ( rchoice
                  ( dom o )
                )
              )
            )
          )
        )
      )
      ( def G p )
    )
  )
)
;---------------------
;
; One-point crossover
;

( def crossover1 lambda
  ( s i )
  ( if
    ( gt i
      ( PS GV )
    )
    ( makeff )
    ( if
      ( prob
        ( PC GV ) 100
      )
      ( plus
        ( _cross1_ s i )
        ( crossover1 s
          ( add i 2 )
        )
      )
      ( plus
        ( _ncross_ s i )
        ( crossover1 s
          ( add i 1 )
        )
      )
    )
  )
)
;---------------------

( def _cross1_ lambda
  ( s k )
  ( let
    (
      ( x
        ( rchoice
          ( dom s )
        )
      )
      ( y
        ( rchoice
          ( dom s )
        )
      )
      ( cs
        ( CS GV )
      )
      ( cp
        ( rand cs )
      )
      ( cx
        ( gpSEL x 1 )
      )
      ( cy
        ( gpSEL y 1 )
      )
      ( nx
        ( append
          ( seq
            ( nth i cx )
            ( from i
              ( inseg cp )
            )
          )
          ( seq
            ( nth i cy )
            ( from i
              ( set k
                ( from k
                  ( inseg cs )
                  ( gt k cp )
                )
              )
            )
          )
        )
      )
      ( ny
        ( append
          ( seq
            ( nth i cy )
            ( from i
              ( inseg cp )
            )
          )
          ( seq
            ( nth i cx )
            ( from i
              ( set k
                ( from k
                  ( inseg cs )
                  ( gt k cp )
                )
              )
            )
          )
        )
      )
      ( fx
        ( gpSEL x 2 )
      )
      ( fy
        ( gpSEL y 2 )
      )
      ( sx
        ( gpSEL x 3 )
      )
      ( sy
        ( gpSEL y 3 )
      )
      ( rfx
        ( gpSEL x 4 )
      )
      ( rfy
        ( gpSEL y 4 )
      )
      ( cfx
        ( gpSEL x 5 )
      )
      ( cfy
        ( gpSEL y 5 )
      )
    )
    ( makeff
      ( k
        ( R nx fx sx rfx cfx )
      )
      (
        ( add k 1 )
        ( R ny fy sy rfy cfy )
      )
    )
  )
)
;---------------------

( def _ncross_ lambda
  ( s k )
  ( let
    (
      ( x
        ( rchoice
          ( dom s )
        )
      )
    )
    ( makeff
      ( k
        ( ap s x )
      )
    )
  )
)
;---------------------
;
; Two-point crossover
;

( def crossover2 lambda
  ( s i )
  ( if
    ( gt i
      ( PS GV )
    )
    ( makeff )
    ( if
      ( prob
        ( PC GV ) 100
      )
      ( plus
        ( _cross2_ s i )
        ( crossover2 s
          ( add i 2 )
        )
      )
      ( plus
        ( _ncross_ s i )
        ( crossover2 s
          ( add i 1 )
        )
      )
    )
  )
)
;---------------------
;p1 = princ("\ncp1=",cp1),
;p2 = princ("\ncp2=",cp2),

( def _cross2_ lambda
  ( s k )
  ( let
    (
      ( x
        ( rchoice
          ( dom s )
        )
      )
      ( y
        ( rchoice
          ( dom s )
        )
      )
      ( cs
        ( CS GV )
      )
      ( cp1
        ( rand cs )
      )
      ( cp2
        ( rand2 cp1 cs )
      )
      ( cx
        ( gpSEL x 1 )
      )
      ( cy
        ( gpSEL y 1 )
      )
      ( nx
        ( append
          ( append
            ( seq
              ( nth i cx )
              ( from i
                ( inseg cp1 )
              )
            )
            ( seq
              ( nth i cy )
              ( from i
                ( set k
                  ( from k
                    ( inseg cp2 )
                    ( gt k cp1 )
                  )
                )
              )
            )
          )
          ( seq
            ( nth i cx )
            ( from i
              ( set k
                ( from k
                  ( inseg cs )
                  ( gt k cp2 )
                )
              )
            )
          )
        )
      )
      ( ny
        ( append
          ( append
            ( seq
              ( nth i cy )
              ( from i
                ( inseg cp1 )
              )
            )
            ( seq
              ( nth i cx )
              ( from i
                ( set k
                  ( from k
                    ( inseg cp2 )
                    ( gt k cp1 )
                  )
                )
              )
            )
          )
          ( seq
            ( nth i cy )
            ( from i
              ( set k
                ( from k
                  ( inseg cs )
                  ( gt k cp2 )
                )
              )
            )
          )
        )
      )
      ( fx
        ( gpSEL x 2 )
      )
      ( fy
        ( gpSEL y 2 )
      )
      ( sx
        ( gpSEL x 3 )
      )
      ( sy
        ( gpSEL y 3 )
      )
      ( rfx
        ( gpSEL x 4 )
      )
      ( rfy
        ( gpSEL y 4 )
      )
      ( cfx
        ( gpSEL x 5 )
      )
      ( cfy
        ( gpSEL y 5 )
      )
    )
    ( makeff
      ( k
        ( R nx fx sx rfx cfx )
      )
      (
        ( add k 1 )
        ( R ny fy sy rfy cfy )
      )
    )
  )
)
;---------------------
;
; Uniform crossover
;

( def ucrossover lambda
  ( s i )
  ( if
    ( gt i
      ( PS GV )
    )
    ( makeff )
    ( if
      ( prob
        ( PC GV ) 100
      )
      ( plus
        ( _ucross_ s i )
        ( ucrossover s
          ( add i 2 )
        )
      )
      ( plus
        ( _ncross_ s i )
        ( ucrossover s
          ( add i 1 )
        )
      )
    )
  )
)
;---------------------

( def _ucross_ lambda
  ( s k )
  ( let
    (
      ( x
        ( rchoice
          ( dom s )
        )
      )
      ( y
        ( rchoice
          ( dom s )
        )
      )
      ( cs
        ( CS GV )
      )
      ( cx
        ( gpSEL x 1 )
      )
      ( cy
        ( gpSEL y 1 )
      )
      ( _
        ( _ucrossover_ cx cy )
      )
      ( nx
        ( first _ )
      )
      ( ny
        ( second _ )
      )
      ( fx
        ( gpSEL x 2 )
      )
      ( fy
        ( gpSEL y 2 )
      )
      ( sx
        ( gpSEL x 3 )
      )
      ( sy
        ( gpSEL y 3 )
      )
      ( rfx
        ( gpSEL x 4 )
      )
      ( rfy
        ( gpSEL y 4 )
      )
      ( cfx
        ( gpSEL x 5 )
      )
      ( cfy
        ( gpSEL y 5 )
      )
    )
    ( makeff
      ( k
        ( R nx fx sx rfx cfx )
      )
      (
        ( add k 1 )
        ( R ny fy sy rfy cfy )
      )
    )
  )
)
;---------------------

( def _ucrossover_ lambda
  ( cx cy )
  ( if
    ( or
      ( equal cx
        ( makeseq )
      )
      ( equal cy
        ( makeseq )
      )
    )
    ( makeseq
      ( makeseq )
      ( makeseq )
    )
    ( let
      (
        ( hx
          ( hd cx )
        )
        ( hy
          ( hd cy )
        )
        ( tx
          ( tl cx )
        )
        ( ty
          ( tl cy )
        )
        ( tt
          ( _ucrossover_ tx ty )
        )
      )
      ( if
        ( prob
          ( PU GV ) 100
        )
        ( makeseq
          ( cons hy
            ( p1 tt )
          )
          ( cons hx
            ( p2 tt )
          )
        )
        ( makeseq
          ( cons hx
            ( p1 tt )
          )
          ( cons hy
            ( p2 tt )
          )
        )
      )
    )
  )
)
;---------------------

( def _ops
  ( plus _ops
    ( makeff
      (
        ( quote gpMUTATION )
        ( quote
          (
            ( ) NIL
          )
        )
      )
    )
  )
)
;---------------------

( def gpMUTATION lambda
  ( )
  ( cond
    (
      ( equal
        ( GR GV ) 0
      )
      ( def G
        ( mutation G )
      )
    )
    (
      ( equal
        ( GR GV ) 1
      )
      ( def G
        ( mutation10 G )
      )
    )
    (
      ( equal
        ( GR GV ) 2
      )
      ( def G
        ( mutation10l G )
      )
    )
  )
)
;---------------------

( def mutation lambda
  ( s )
  ( if
    ( equal s
      ( makeff )
    )
    ( makeff )
    ( let
      (
        ( x
          ( choice
            ( dom s )
          )
        )
        ( c
          ( seq
            ( _mutate_ k )
            ( from k
              ( gpSEL x 1 )
            )
          )
        )
        ( fx
          ( gpSEL x 2 )
        )
        ( sx
          ( gpSEL x 3 )
        )
        ( rfx
          ( gpSEL x 4 )
        )
        ( cfx
          ( gpSEL x 5 )
        )
      )
      ( plus
        ( makeff
          ( x
            ( R c fx sx rfx cfx )
          )
        )
        ( mutation
          ( ds s
            ( makeset x )
          )
        )
      )
    )
  )
)
;---------------------

( def _mutate_ lambda
  ( bit )
  ( if
    ( prob
      ( PM GV ) 100
    )
    ( cond
      (
        ( equal bit 0 ) 1
      )
      (
        ( equal bit 1 ) 0
      )
    ) bit
  )
)
;---------------------

( def mutation10 lambda
  ( s )
  ( if
    ( equal s
      ( makeff )
    )
    ( makeff )
    ( let
      (
        ( x
          ( choice
            ( dom s )
          )
        )
        ( c
          ( seq
            ( _mutate10_ k )
            ( from k
              ( gpSEL x 1 )
            )
          )
        )
        ( fx
          ( gpSEL x 2 )
        )
        ( sx
          ( gpSEL x 3 )
        )
        ( rfx
          ( gpSEL x 4 )
        )
        ( cfx
          ( gpSEL x 5 )
        )
      )
      ( plus
        ( makeff
          ( x
            ( R c fx sx rfx cfx )
          )
        )
        ( mutation10
          ( ds s
            ( makeset x )
          )
        )
      )
    )
  )
)
;---------------------

( def mutation10l lambda
  ( s )
  ( if
    ( equal s
      ( makeff )
    )
    ( makeff )
    ( let
      (
        ( x
          ( choice
            ( dom s )
          )
        )
        ( c
          ( seq
            (
              ( lambda
                ( _y_ )
                ( seq
                  ( _mutate10_ _x_ )
                  ( from _x_ _y_ )
                )
              ) k
            )
            ( from k
              ( gpSEL x 1 )
            )
          )
        )
        ( fx
          ( gpSEL x 2 )
        )
        ( sx
          ( gpSEL x 3 )
        )
        ( rfx
          ( gpSEL x 4 )
        )
        ( cfx
          ( gpSEL x 5 )
        )
      )
      ( plus
        ( makeff
          ( x
            ( R c fx sx rfx cfx )
          )
        )
        ( mutation10l
          ( ds s
            ( makeset x )
          )
        )
      )
    )
  )
)
;---------------------

( def _mutate10_ lambda
  ( dig )
  ( if
    ( prob
      ( PM GV ) 100
    )
    ( rand
      ( MV GV )
    ) dig
  )
)
;---------------------

( def _ops
  ( plus _ops
    ( makeff
      (
        ( quote gpEVAL )
        ( quote
          (
            ( ) NIL
          )
        )
      )
    )
  )
)
;---------------------

( def gpEVAL lambda
  ( )
  ( def G
    ( rcprob
      ( evalf G )
    )
  )
)
;---------------------

( def evalf lambda
  ( s )
  ( if
    ( equal s
      ( makeff )
    )
    ( makeff )
    ( let
      (
        ( x
          ( choice
            ( dom s )
          )
        )
        ( cx
          ( gpSEL x 1 )
        )
        ( sx
          ( gpSEL x 3 )
        )
      )
      ( plus
        ( makeff
          ( x
            ( R cx
              ( _evalf_ cx ) sx 0 0
            )
          )
        )
        ( evalf
          ( ds s
            ( makeset x )
          )
        )
      )
    )
  )
)
;---------------------

( def _ops
  ( plus _ops
    ( makeff
      (
        ( quote gpBEST )
        ( quote
          (
            ( )
            ( FF I R )
          )
        )
      )
    )
  )
)
;---------------------

( def gpBEST lambda
  ( )
  ( ff1
    ( list k
      ( ap G k )
    )
    ( from k
      ( dom G )
      ( equal
        ( gpSEL k 2 )
        ( reduce 0 max
          ( set
            ( gpSEL x 2 )
            ( from x
              ( dom G )
            )
          )
        )
      )
    )
  )
)
;---------------------
;            b = ([ k -> <gpSEL(k,1),gpSEL(k,2)> | k <- dom(G) : gpSEL(k,2) == m ]),
;       in < _evalf_(b[c]),b[c] >;

( def _ops
  ( plus _ops
    ( makeff
      (
        ( quote gpBESTVAL )
        ( quote
          (
            ( )
            ( FF I R )
          )
        )
      )
    )
  )
)
;---------------------

( def gpBESTVAL lambda
  ( )
  ( if
    ( not
      ( gpEMPTY )
    )
    ( let
      (
        ( m
          ( reduce 0 max
            ( set
              ( gpSEL x 2 )
              ( from x
                ( dom G )
              )
            )
          )
        )
        ( b
          ( ff1
            ( list k
              ( ap G k )
            )
            ( from k
              ( dom G )
              ( equal
                ( gpSEL k 2 ) m
              )
            )
          )
        )
        ( c
          ( choice
            ( dom b )
          )
        )
      )
      ( makeff
        ( c
          ( ap b c )
        )
      )
    )
    ( strcat "ERROR (precondition violated) in function " "gpBESTVAL" )
  )
)
;---------------------

( def _ops
  ( plus _ops
    ( makeff
      (
        ( quote gpEVOLUTION )
        ( quote
          (
            (
              ( INT )
            ) NIL
          )
        )
      )
    )
  )
)
;---------------------

( def gpEVOLUTION lambda
  ( n )
  ( progn
    ( gpSTART )
    ( gpEVAL )
    ( def fp
      ( fopen "w" "_" )
    )
    ( princ "> Best(" 0 "): "
      ( mypptex
        ( gpBESTVAL )
      ) "\n> thinking..."
    )
    ( foreach x
      ( inseg n )
      ( gpSELECT )
      ( gpCROSSOVER )
      ( gpMUTATION )
      ( gpEVAL )
      ( princ " best (" x "): "
        ( mypptex
          ( gpBESTVAL )
        ) "\n> thinking..."
      )
    )
    ( fclose fp )
  )
)
;---------------------

( def mypp lambda
  ( x )
  ( let
    (
      ( a
        ( choice
          ( dom x )
        )
      )
      ( b
        ( ap x a )
      )
    )
    ( strcat
      ( strcat
        ( strcat
          ( strcat
            ( strcat
              ( strcat
                ( strcat
                  ( strcat "IND("
                    ( itoa a )
                  ) ") with CROM("
                ) "<"
              )
              ( pplst
                ( p1 b )
              )
            ) ">"
          ) ") and EVAL("
        )
        ( itoa
          ( p2 b )
        )
      ) ")"
    )
  )
)
;---------------------

( def mypptex lambda
  ( x )
  ( let
    (
      ( a
        ( choice
          ( dom x )
        )
      )
      ( b
        ( ap x a )
      )
      ( s
        ( strcat
          ( strcat
            ( strcat
              ( strcat
                ( strcat
                  ( strcat
                    ( strcat
                      ( itoa a ) " & "
                    ) "$<"
                  )
                  ( pplst
                    ( p1 b )
                  )
                ) ">$"
              ) " & "
            )
            ( itoa
              ( p2 b )
            )
          ) "\\\\ \n\\hline\\\\\n"
        )
      )
    )
    ( fprint "_" "a"
      ( makeseq s )
    )
  )
)
;---------------------

( def pplst lambda
  ( l )
  ( if
    ( equal l
      ( makeseq )
    ) ""
    ( strcat
      ( strcat
        ( itoa
          ( hd l )
        ) ","
      )
      ( pplst
        ( tl l )
      )
    )
  )
)
;---------------------

( def _ops
  ( plus _ops
    ( makeff
      (
        ( quote gpSETTINGS )
        ( quote
          (
            (
              ( P )
            ) NIL
          )
        )
      )
    )
  )
)
;---------------------

( def gpSETTINGS lambda
  ( p )
  ( def GV
    ( P
      ( CS p )
      ( PS p )
      ( SS p )
      ( PC p )
      ( PU p )
      ( PM p )
      ( VC p )
      ( CT p )
      ( BS p )
      ( GR p )
      ( add
        ( MV p ) 1
      )
    )
  )
)
;---------------------

( def _ops
  ( plus _ops
    ( makeff
      (
        ( quote gpSHOWSETTINGS )
        ( quote
          (
            ( ) NIL
          )
        )
      )
    )
  )
)
;---------------------

( def gpSHOWSETTINGS lambda
  ( )
  ( princ "CS (Chromsize)                   = "
    ( CS GV ) "\nPS (Population Size)             = "
    ( PS GV ) "\nSS (Segment Size)                = "
    ( SS GV ) " (decimal list representation only)" "\nPC (Probability Crossover)       = "
    ( PC GV ) "%" "\nPU (Probability Unif. Crossover) = "
    ( PU GV ) "%" "\nPM (Probability Mutation)        = "
    ( PM GV ) "%" "\nVC (Variable Size Chrom.)        = "
    ( VC GV ) " (true/false)" "\nCT (Crossover type)              = "
    ( CT GV ) " (1=one-point, 2=two-point,3=unif.)" "\nBS (Best survives)               = "
    ( BS GV ) " (true/false)" "\nGR (Gene Representation)         = "
    ( GR GV ) " (0=binary, 1=decimal, 2=decimal-list)" "\nMV (Maximum Gene Value)          = "
    ( MV GV ) " (decimal and dec-list representation only)" "\n"
  )
)
;---------------------

( def _ops
  ( plus _ops
    ( makeff
      (
        ( quote gpRULES )
        ( quote
          (
            (
              ( I )
            )
            ( LIST INT )
          )
        )
      )
    )
  )
)
;---------------------

( def gpRULES lambda
  ( a )
  ( if
    ( member a
      ( dom G )
    )
    ( let
      (
        ( c 1 )
        ( ps
          ( SS GV )
        )
        ( cx
          ( gpSEL a 1 )
        )
      )
      ( _c2rules_ c ps cx )
    )
    ( strcat "ERROR (precondition violated) in function " "gpRULES" )
  )
)
;---------------------

( def _c2rules_ lambda
  ( c ps cx )
  ( let
    (
      ( l
        ( length cx )
      )
    )
    ( if
      ( gt c l )
      ( makeseq )
      ( let
        (
          ( cp
            ( seq
              ( nth i cx )
              ( from i
                ( inseg l )
                ( and
                  ( geq i c )
                  ( leq i
                    ( sub
                      ( add c ps ) 1
                    )
                  )
                )
              )
            )
          )
        )
        ( cons
          ( bin2dec cp )
          ( _c2rules_
            ( add c ps ) ps cx
          )
        )
      )
    )
  )
)
;---------------------

( def bin2dec lambda
  ( s )
  ( if
    ( equal s
      ( makeseq )
    ) 0
    ( if
      ( equal
        ( hd s ) 1
      )
      ( let
        (
          ( l
            ( sub
              ( length s ) 1
            )
          )
          ( v
            ( cond
              (
                ( equal l 0 ) 1
              )
              (
                ( equal l 1 ) 2
              )
              (
                ( equal l 2 ) 4
              )
              (
                ( equal l 3 ) 8
              )
              (
                ( equal l 4 ) 16
              )
              (
                ( equal l 5 ) 32
              )
              (
                ( equal l 6 ) 64
              )
              (
                ( equal l 7 ) 128
              )
              (
                ( equal l 8 ) 256
              )
              (
                ( equal l 9 ) 512
              )
              (
                ( equal l 10 ) 1024
              )
              ( true
                ( princ "\n!..out of range...\n" )
              )
            )
          )
        )
        ( add v
          ( bin2dec
            ( tl s )
          )
        )
      )
      ( bin2dec
        ( tl s )
      )
    )
  )
)
;---------------------