types.qky

[ $ 'lookup-table.qky' ALEx-load ] now!

[ this ] is types.qky

( ------ Polimorphism ------
  Copyright (C) 2021 Aleksander "olus2000" Sabak
  https://github.com/olus2000                                         )

( This extension depends on the "lookup-table.qky" to be loaded.

  This extension supports a simple object type system and polimorphic
  words. Each type is identified by a type identifier and all objects
  of a type are nests with its type identifier at the beginning,
  followed by object's fields.
  
  Object structure:
    [ type-id field1 field2 ... ]
  
  Simple types make objects that should only ever be interpreted as
  data and never executed. A type id of a simple type should be a
  number generated by the builder `type`. Example of a simple type:
  
    type is 2D-point
    [ 2D-point 2 1 ] is point-A
    [ 2D-point 3 7 ] is point-B
  
  Action types make objects with some sort of behavior when executed.
  Their type id should be a nest performing that action based on
  object's fields. Most actions should end with `]done[` to prevent
  execution of object's fields. The standard Quackery system defines
  two great examples of action types: `table` and `stack`. Another
  one can be found in the "lookup-table.qky" extension.
  
  To facilitate polimorphism this extension provides a new kind of
  words: generic. Generic words are first declared without any
  behavior and later can be implemented separately for each type.
  Each generic word takes an object as its top parameter and decides
  which behavior will be executed based on the object's type.
  Example usage of generic words can be seen at the end of the file.

  # Glossary:
  
  type ( [ $ -- [ $ ):
   
    Builder. Adds the next free simple type id to the built nest and
    increments the counter in `type.id`. Should be used for defining
    simple types.
    
    Example usage:
    
    type is 2D-vector
    
    [ 2D-vector 4 5 ] is vec1

  type.id ( -- [ ):

    A stack holding a number not yet used as a simple type identifier
    when generating types with `type`. 
  
  generic ( [ $ -- [ $ ):
  
    Builder. Takes a name that follows it and defines a new generic
    word with that name and extendable behavior. The top parameter of
    that word has to be an object and action performed by a generic
    word depends on the type of the object passed to it.
    
    Example usage:
    
    generic magnitude-square

  generic.action ( ..a obj [ generic.action actions-lut ] -- ..b ):

    An action type identifier of generic words. It's action is to
    dispatch the actions-lut on the object passed as the argument
    and `do` the corresponding action or `bail` if no action is
    associated with the object's type.

  <generic> ( -- new-generic ):
  
    A constructor for objects representing generic words.

  generic? ( obj -- ? ):

    A predicate for generic words. Returns `true` if the object's type
    id is `generic.action` and `false` otherwise. Returns `false` if
    not passed a nest.
  
  behavior ( [ $ -- [ $ ):
  
    Builder. Expects three values to have already been built:
    an action, a type and a generic word. It sets the behavior of the
    generic word when acting on the type to be the action. 
    
    Example usage:
    
    [ dup 1 peek 2 **
      swap 2 peek 2 ** + ] 2D-vector magnitude-square behavior

  lut.set-at ( value key lut -- ):
  set-at

    `set-at` for lookup tables is redefined to be a generic word with
    behavior defined for lookup tables.                               )


[ stack 0 ]                                   is type.id ( -- [ )


[ over
  type.id share
  swap put
  1 type.id tally ]                       builds type ( [ $ -- [ $ )


[ dup nest? not if
  [ $ 'Non-nest passed to a generic word.'
    message put bail ]
  dup 0 peek
  ]'[ do not if
  [ $ 'Generic word undefined for this type.'
    message put bail ]
  do ]done[ ]                                 is generic.action 
                            ( ..a obj [ generic.action actions-lut ] -- ..b )


[ ' generic.action nested
  <lut> nested join ]                         is <generic> ( -- new-generic )


[ dup nest? not iff
  [ drop false ] done
  0 peek ' generic.action oats ]              is generic? ( obj -- ? )


[ dup $ '' = if
  [ $ '`generic` needs a name after it.'
    message put bail ]
  nextword dup
  name? if
  [ dup build share
    generic? iff
    drop ]done[ ]
  ( the following is literally code copied from `is`
    if tere only was a way of reusing builder functionality... )
  nested
  namenest take
  join
  namenest put
  <generic>
  actiontable take
  1 stuff
  actiontable put ]                       builds generic ( [ $ -- [ $ )


[ over size 3 < if
  [ $ '`behavior` needs a behavior, a type and a generic word.'
    message put
    bail ]
  over dup take
  over take
  rot take
  swap rot 1 peek
  set-at ]                                builds behavior ( [ $ -- [ $ )


( ----- set-at as a generic ----- )

set-at is lut.set-at ( value key lut -- )
generic set-at
lut.set-at lut set-at behavior



( ----- example ----- )
[ drop $ '' ] now! ( comment this line to run the example code )


type is pair   ( [ pair a b ] )
type is triple ( [ triple a b c ] )
generic sum    ( obj -- n )


[ dup 1 peek
  swap 2 peek + ] pair sum behavior ( pair -- n )

[ dup 1 peek
  over 2 peek +
  swap 3 peek + ] triple sum behavior ( triple -- n )

[ 0 over size
  1 - times
  [ over i
    swap do + ]
  nip ]           table sum behavior ( table -- n )


say "The sum of pair 2 and 7 is "
' [ pair 2 7 ] sum echo cr

say "The sum of a triple 1, 4 and 6 is "
' [ triple 1 4 6 ] sum echo cr

say "The sum of a table of odd numbers less than 10 is "
' [ table 1 3 5 7 9 ] sum echo cr