Initial commit: import and cleanup of the feuforeve.fr website to promote the Floraverse section into an independent website.
This commit is contained in:
Feufochmar
commit
2e6aea78f4
|
|
@ -0,0 +1,40 @@
|
|||
#lang racket/base
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
;; Tests to be run with raco test
|
||||
)
|
||||
|
||||
(module+ main
|
||||
(require
|
||||
"src/webcontainer/webcontainer.rkt"
|
||||
"src/webcontainer/website.rkt"
|
||||
"src/pages/sitemap.rkt"
|
||||
"src/pages/floraverse.rkt")
|
||||
; Website
|
||||
(define *website*
|
||||
(website
|
||||
"" weblet pages:floraverse
|
||||
("CharacterGenerator" weblet pages:floraverse-character-generator
|
||||
("Tweet" weblet pages:floraverse-character-generator-tweet))
|
||||
("AboutCharacterGenerator" weblet pages:floraverse-character-generator-about)
|
||||
("Calendar" weblet pages:floraverse-calendar)
|
||||
("Calendar/{month}/{day}" matching-weblet pages:floraverse-calendar)
|
||||
))
|
||||
; Sitemap
|
||||
(sitemap
|
||||
'(("Home" "/" #f)
|
||||
("Character Generator" "/CharacterGenerator" #t)
|
||||
("Calendar" "/Calendar" #f)
|
||||
("About the character generator" "/AboutCharacterGenerator" #f))
|
||||
)
|
||||
; Webcontainer
|
||||
(define *webcontainer*
|
||||
(make-webcontainer
|
||||
#:static
|
||||
(make-immutable-hash
|
||||
`(("" . "./static")))))
|
||||
(webcontainer-add-website! *webcontainer* *website*)
|
||||
(webcontainer-set-404-weblet! *webcontainer* pages:not-found)
|
||||
(display "Starting server...")(newline)
|
||||
(webcontainer-start *webcontainer*))
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,38 @@
|
|||
#lang racket/base
|
||||
|
||||
(require
|
||||
"random.rkt")
|
||||
|
||||
; Category generator
|
||||
; Generate collections of items from named lists
|
||||
(provide
|
||||
jsexpr->category-generator
|
||||
category-generate
|
||||
category-generate-list
|
||||
category-generate-dictionary
|
||||
)
|
||||
|
||||
; Read from a json expresion
|
||||
; The model is directly the structure read from json (which is a hash)
|
||||
(define (jsexpr->category-generator js)
|
||||
js)
|
||||
|
||||
; Generate one element from a given category
|
||||
(define (category-generate gen (cat #f))
|
||||
(random:from-list
|
||||
(if cat
|
||||
(hash-ref gen cat)
|
||||
(cdr (random:from-hash gen)))))
|
||||
|
||||
; Generate a list of n elements from a category
|
||||
(define (category-generate-list gen cat n)
|
||||
(random:sublist (hash-ref gen cat) n))
|
||||
|
||||
; Generate a dictionary of category => item
|
||||
(define (category-generate-dictionary gen)
|
||||
(let ((ret (make-hash)))
|
||||
(hash-for-each
|
||||
gen
|
||||
(lambda (k v)
|
||||
(hash-set! ret k (random:from-list v))))
|
||||
ret))
|
||||
|
|
@ -0,0 +1,182 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide
|
||||
distribution
|
||||
make-distribution
|
||||
distribution-generate
|
||||
distribution-add-to!
|
||||
distribution-contains?
|
||||
distribution-check-only
|
||||
distribution-linear-combination
|
||||
distribution-items
|
||||
distribution-filter
|
||||
distribution-empty?
|
||||
; List format
|
||||
distribution->jsexpr
|
||||
jsexpr->distribution
|
||||
; Object format
|
||||
distribution->jsexpr/object
|
||||
jsexpr->distribution/object
|
||||
)
|
||||
|
||||
; Distribution structure
|
||||
; Distributions are list of items associated to a number indicating its frequency.
|
||||
; When an element is picked from the list, the frequency of the items is taken into account.
|
||||
(struct s-distribution
|
||||
([total #:mutable] ; total number of elements in the distribution
|
||||
[lst-items #:mutable] ; same as items, but in a assoc-list
|
||||
items)) ; hash item -> number of occurences
|
||||
|
||||
; Exported function
|
||||
(define distribution-items s-distribution-items)
|
||||
|
||||
; Add an item to the distribution, with its number of occurences
|
||||
(define (distribution-add-to! d itm [additionnal-occurences 1])
|
||||
(define occurences (hash-ref (distribution-items d) itm 0))
|
||||
(hash-set! (s-distribution-items d) itm (+ occurences additionnal-occurences))
|
||||
(set-s-distribution-lst-items! d (hash->list (s-distribution-items d)))
|
||||
(set-s-distribution-total! d (+ (s-distribution-total d) additionnal-occurences)))
|
||||
|
||||
; Constructor with a list of item/occurences pairs
|
||||
; item is (car pair), occurence is (cdr pair)
|
||||
(define (distribution . pairs)
|
||||
(s-distribution
|
||||
(foldl
|
||||
(lambda (p res) (+ res (cdr p)))
|
||||
0
|
||||
pairs)
|
||||
pairs
|
||||
(make-hash pairs)))
|
||||
|
||||
; Syntax to build a distribution from the items and theirs occurences
|
||||
; This syntax allow default values for items
|
||||
; Note: the item is quoted
|
||||
(define-syntax make-distribution
|
||||
(syntax-rules (*)
|
||||
; No arguments - default constructor
|
||||
((make-distribution)
|
||||
(s-distribution 0 (list) (make-hash)))
|
||||
; default syntax
|
||||
((make-distribution (id val) ...)
|
||||
(let ((dist (distribution)))
|
||||
(begin
|
||||
(distribution-add-to! dist (quote id) val) ...)
|
||||
dist))
|
||||
; From a list and default values
|
||||
((make-distribution lst (* default-val))
|
||||
(let ((dist (distribution)))
|
||||
(for-each
|
||||
(lambda (x) (distribution-add-to! dist x default-val))
|
||||
lst)
|
||||
dist))
|
||||
; From a list, default values and values overriding the defaults
|
||||
((make-distribution lst (* default-val) (id val) ...)
|
||||
(let ((h (make-hash))
|
||||
(dist (distribution)))
|
||||
(for-each
|
||||
(lambda (x) (hash-set! h x default-val))
|
||||
lst)
|
||||
(begin
|
||||
(hash-set! h (quote id) val) ...)
|
||||
(hash-for-each h (lambda (k v) (distribution-add-to! dist k v)))
|
||||
dist))
|
||||
; With a useless list
|
||||
((make-distribution lst (id val) ...)
|
||||
(let ((dist (distribution)))
|
||||
(begin
|
||||
(distribution-add-to! dist (quote id) val) ...)
|
||||
dist))
|
||||
))
|
||||
|
||||
; Generate an item from a distribution
|
||||
(define (distribution-generate d)
|
||||
; Search function
|
||||
(define (search lst subtotal roll)
|
||||
(define new-subtotal (+ subtotal (cdar lst)))
|
||||
(if (< roll new-subtotal)
|
||||
(caar lst)
|
||||
(search (cdr lst) new-subtotal roll)))
|
||||
(search (s-distribution-lst-items d) 0 (random (s-distribution-total d))))
|
||||
|
||||
; Check if an item is in the distribution
|
||||
(define (distribution-contains? d itm)
|
||||
(hash-has-key? (s-distribution-items d) itm))
|
||||
|
||||
; Check if there are unkown items in the distribution
|
||||
; Raise an error if an unkown item is present
|
||||
(define (distribution-check-only d known-items)
|
||||
(hash-for-each
|
||||
(s-distribution-items d)
|
||||
(lambda (k v)
|
||||
(when (not (member k known-items))
|
||||
(error "Distribution contains an unknown item: " k)))))
|
||||
|
||||
; Linear combination of distributions
|
||||
; Make a new distribution from a dotted list of distributions and their weight
|
||||
(define (distribution-linear-combination dists)
|
||||
(define d (distribution))
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(define itms
|
||||
(hash-map
|
||||
(s-distribution-items (car x))
|
||||
(lambda (k v)
|
||||
(cons k (/ v (s-distribution-total (car x)))))))
|
||||
(for-each
|
||||
(lambda (itm)
|
||||
(distribution-add-to! d (car itm) (truncate (* (cdr x) (cdr itm) 100)))) ; * 100 and truncate because (cdr itm) is reduced
|
||||
itms))
|
||||
dists)
|
||||
d)
|
||||
|
||||
; Make a new distribution by filtering an existing distribution and keeping only the values that check a predicate
|
||||
(define (distribution-filter d pred)
|
||||
(apply
|
||||
distribution
|
||||
(filter
|
||||
(lambda (x) (pred (car x)))
|
||||
(s-distribution-lst-items d))))
|
||||
|
||||
; Return true if the distribution is empty: no element in it
|
||||
(define (distribution-empty? d)
|
||||
(eq? 0 (s-distribution-total d)))
|
||||
|
||||
; Serialisation to a json-compatible structure
|
||||
; It is possible to pass a translator function for converting values that are not compatible to json
|
||||
(define (distribution->jsexpr dist #:translator [tr (lambda (x) x)])
|
||||
(hash-map
|
||||
(s-distribution-items dist)
|
||||
(lambda (k v)
|
||||
(make-immutable-hash
|
||||
`((value . ,(tr k))
|
||||
(count . ,v))))))
|
||||
|
||||
; Object version: the distribution is serialised as an object whose attribute names are the distribution values and associated to their occurences.
|
||||
; The translation function applies to the distribution values, and must return a symbol
|
||||
(define (distribution->jsexpr/object dist #:translator [tr (lambda (x) x)])
|
||||
(define ret (make-hash))
|
||||
(hash-for-each
|
||||
(s-distribution-items dist)
|
||||
(lambda (k v)
|
||||
(hash-set! (tr k) v)))
|
||||
ret)
|
||||
|
||||
; Deserialisation from a json-compatible structure
|
||||
; It is possible to pass a translator function for converting values that are not compatible to json
|
||||
(define (jsexpr->distribution js #:translator [tr (lambda (x) x)])
|
||||
(define dist (distribution))
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(distribution-add-to! dist (tr (hash-ref x 'value)) (hash-ref x 'count)))
|
||||
js)
|
||||
dist)
|
||||
|
||||
; Object version: the distribution is serialised as an object whose attribute names are the distribution values and associated to their occurences.
|
||||
; The translation function applies to the distribution values, and must take a symbol in parameter
|
||||
(define (jsexpr->distribution/object js #:translator [tr (lambda (x) x)])
|
||||
(define dist (distribution))
|
||||
(hash-for-each
|
||||
js
|
||||
(lambda (k v)
|
||||
(distribution-add-to! dist (tr k) v)))
|
||||
dist)
|
||||
|
|
@ -0,0 +1,108 @@
|
|||
#lang racket/base
|
||||
|
||||
(require
|
||||
racket/list
|
||||
"distribution.rkt")
|
||||
(provide make-markov
|
||||
markov-add-example!
|
||||
markov-add-next-item!
|
||||
markov-generate
|
||||
markov->jsexpr
|
||||
jsexpr->markov)
|
||||
|
||||
; Markov chain structure
|
||||
(struct markov
|
||||
(order ; order of the chain
|
||||
next-items)) ; table of given sequence -> distributions of next possible items
|
||||
|
||||
; Constructor
|
||||
(define (make-markov [order 1])
|
||||
(markov order (make-hash)))
|
||||
|
||||
; Add a example to the generator. The example is a sequence of values in a list.
|
||||
(define (markov-add-example! mrk example)
|
||||
(letrec
|
||||
((fill
|
||||
(lambda (lst prev)
|
||||
(let ((distro (hash-ref (markov-next-items mrk) prev #f))
|
||||
(next (if (null? lst) #f (car lst))))
|
||||
(if distro
|
||||
(distribution-add-to! distro next)
|
||||
(let ((new-distro (make-distribution)))
|
||||
(distribution-add-to! new-distro next)
|
||||
(hash-set! (markov-next-items mrk) prev new-distro)))
|
||||
(when next (fill (cdr lst) (append (cdr prev) (list next))))
|
||||
))))
|
||||
(fill example (make-list (markov-order mrk) #f))
|
||||
))
|
||||
|
||||
; Add a possible next item from a sequence
|
||||
; Use this to regenerate a markov chain from a serialized version (ie not from examples)
|
||||
(define (markov-add-next-item! mrk seq next [occurences 1])
|
||||
(let ((distro (hash-ref (markov-next-items mrk) seq #f)))
|
||||
(if distro
|
||||
(distribution-add-to! distro next occurences)
|
||||
(let ((new-distro (make-distribution)))
|
||||
(distribution-add-to! new-distro next occurences)
|
||||
(hash-set! (markov-next-items mrk) seq new-distro)))))
|
||||
|
||||
; Generate a list with the given initial sequence
|
||||
(define (generate-list next-items result previous)
|
||||
(let ((next (distribution-generate (hash-ref next-items previous))))
|
||||
(if (not next)
|
||||
(reverse result)
|
||||
(generate-list next-items (cons next result) (append (cdr previous) (list next))))))
|
||||
|
||||
; Get a suitable starting sequence from the given list
|
||||
(define (find-starting-sequence next-items initial)
|
||||
; If the given sequence is a suitable sequence, return it
|
||||
(if (hash-has-key? next-items initial)
|
||||
initial
|
||||
(letrec
|
||||
; rating function to compare two sequences
|
||||
((rate
|
||||
(lambda (result a b)
|
||||
(if (or (null? a) (null? b))
|
||||
result
|
||||
(rate (+ result (if (equal? (car a) (car b)) 1 0)) (cdr a) (cdr b))))))
|
||||
; the suitable starting sequence is the one that get the best result with the rate function when compared to the initial sequence
|
||||
(caar
|
||||
(sort
|
||||
(map
|
||||
(lambda (lst) (cons lst (rate 0 (reverse lst) (reverse initial)))) ; The starting sequence is more suitable is we start from the last elements
|
||||
(shuffle
|
||||
(hash-keys next-items)))
|
||||
(lambda (a b) (> (cdr a) (cdr b))))))))
|
||||
|
||||
; Generate a list from the chain
|
||||
(define (markov-generate mrk [initial #f])
|
||||
(if initial
|
||||
(let ((prev (find-starting-sequence (markov-next-items mrk) initial)))
|
||||
(generate-list (markov-next-items mrk) (reverse initial) prev))
|
||||
(generate-list (markov-next-items mrk) (list) (make-list (markov-order mrk) #f))))
|
||||
|
||||
; Serialisation to a json-compatible structure
|
||||
; It is possible to pass a translator function for converting values that are not compatible to json
|
||||
(define (markov->jsexpr mrk #:translator [tr (lambda (x) x)])
|
||||
(make-immutable-hash
|
||||
`((order . ,(markov-order mrk))
|
||||
(next . ,(hash-map
|
||||
(markov-next-items mrk)
|
||||
(lambda (k v)
|
||||
(make-immutable-hash
|
||||
`((sequence . ,(map tr k))
|
||||
(distribution . ,(distribution->jsexpr v #:translator tr)))))))
|
||||
)))
|
||||
|
||||
; Deserialisation from a json-compatible structure
|
||||
; It is possible to pass a translator function for converting values that are not compatible to json
|
||||
(define (jsexpr->markov js #:translator [tr (lambda (x) x)])
|
||||
(define mrk (make-markov (hash-ref js 'order)))
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(hash-set!
|
||||
(markov-next-items mrk)
|
||||
(map tr (hash-ref x 'sequence))
|
||||
(jsexpr->distribution (hash-ref x 'distribution) #:translator tr)))
|
||||
(hash-ref js 'next))
|
||||
mrk)
|
||||
|
|
@ -0,0 +1,106 @@
|
|||
#lang racket/base
|
||||
|
||||
; Various functions working with randomness
|
||||
(require
|
||||
racket/list
|
||||
math/distributions
|
||||
racket/flonum)
|
||||
|
||||
(provide
|
||||
random:boolean random:normal
|
||||
random:from-vector random:from-list random:from-hash
|
||||
random:subvector random:sublist random:subhash
|
||||
hash-key* hash-ref*
|
||||
random:hash-combine
|
||||
)
|
||||
|
||||
; Choose a random boolean
|
||||
(define (random:boolean)
|
||||
(eq? 0 (random 2)))
|
||||
|
||||
; Choose a number using the normal distribution
|
||||
; It is possible to indicate a mean and a standard-deviation
|
||||
(define (random:normal [mean 0.] [dev 1.])
|
||||
(flvector-ref (flnormal-sample mean dev 1) 0))
|
||||
|
||||
; Choose a random element from a vector
|
||||
(define (random:from-vector vec)
|
||||
(if (< 0 (vector-length vec))
|
||||
(vector-ref vec (random (vector-length vec)))
|
||||
(error "Cannot choose an element from an empty vector.")))
|
||||
|
||||
; Choose a random element from a list
|
||||
(define (random:from-list lst)
|
||||
(if (not (null? lst))
|
||||
(car (shuffle lst))
|
||||
(error "Cannot choose an element from an empty list.")))
|
||||
|
||||
; Choose a random element from a hash
|
||||
; return a pair (key . value)
|
||||
(define (random:from-hash hsh)
|
||||
(if (not (hash-empty? hsh))
|
||||
(random:from-list (hash->list hsh))
|
||||
(error "Cannot choose an element from an empty hash.")))
|
||||
|
||||
; Create a list of at most n elements choosen at random from a list
|
||||
(define (random:sublist lst n)
|
||||
; Take at most n element from a list
|
||||
(define (take-at-most in n [out (list)])
|
||||
(if (or (null? in) (eq? n 0))
|
||||
(reverse out)
|
||||
(take-at-most (cdr in) (- n 1) (cons (car in) out))))
|
||||
(take-at-most (shuffle lst) n))
|
||||
|
||||
; Create a vector of at most n elements choosen at random from a vector
|
||||
(define (random:subvector vec n)
|
||||
(list->vector (random:sublist (vector->list vec) n)))
|
||||
|
||||
; Create a hash of at most n elements choosen at random from a hash
|
||||
(define (random:subhash hsh n)
|
||||
(let ((res (make-hash)))
|
||||
(for-each
|
||||
(lambda (c)
|
||||
(hash-set! res (car c) (cdr c)))
|
||||
(random:sublist (hash->list hsh) n))
|
||||
res))
|
||||
|
||||
; Return the key if it is present in the hash or return a random key if it is absent
|
||||
; Return #f if the hash is empty
|
||||
(define (hash-key* hsh key)
|
||||
(cond
|
||||
( (hash-empty? hsh)
|
||||
#f)
|
||||
( (hash-has-key? hsh key)
|
||||
key)
|
||||
( #t
|
||||
(car (random:from-hash hsh)))))
|
||||
|
||||
; Return the value associated to a key in the hash if the key is present
|
||||
; or return a random value from the hash if absent
|
||||
; Return #f if the hash is empty
|
||||
(define (hash-ref* hsh key)
|
||||
(cond
|
||||
( (hash-empty? hsh)
|
||||
#f)
|
||||
( (hash-has-key? hsh key)
|
||||
(hash-ref hsh key))
|
||||
( #t
|
||||
(cdr (random:from-hash hsh)))))
|
||||
|
||||
(define (random:hash-combine . hsh-lst)
|
||||
(define tmp (make-hash))
|
||||
(define ret (make-hash))
|
||||
(for-each
|
||||
(lambda (h)
|
||||
(hash-for-each
|
||||
h
|
||||
(lambda (k v)
|
||||
(if (hash-has-key? tmp k)
|
||||
(hash-set! tmp k (cons v (hash-ref tmp k)))
|
||||
(hash-set! tmp k (list v))))))
|
||||
hsh-lst)
|
||||
(hash-for-each
|
||||
tmp
|
||||
(lambda (k v)
|
||||
(hash-set! ret k (random:from-list v))))
|
||||
ret)
|
||||
|
|
@ -0,0 +1,92 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide
|
||||
tree tree? tree-key tree-value tree-children
|
||||
make-tree tree-ref tree-set!
|
||||
tree-node tree-child tree->list
|
||||
tree-for-each tree-find-path tree-fold)
|
||||
|
||||
; Tree structures, with key and possible value on nodes
|
||||
; Like a table, with a list of keys as reference to a value
|
||||
(struct tree
|
||||
(key ; Key associated to a node. #f for the root of the tree
|
||||
(value #:mutable) ; Value associated to a node. May be #f if the node has no value associated with (it should have children then)
|
||||
(children #:mutable) ; Children list of a node
|
||||
))
|
||||
|
||||
; Constructor
|
||||
; New node of a tree.
|
||||
(define (make-tree [key #f])
|
||||
(tree key #f (list)))
|
||||
|
||||
; Get a child from its key
|
||||
(define (tree-child t key)
|
||||
(let ((child-list
|
||||
(filter
|
||||
(lambda (x) (equal? (tree-key x) key))
|
||||
(tree-children t))))
|
||||
(if (null? child-list)
|
||||
#f
|
||||
(car child-list))))
|
||||
|
||||
; Set a value on the given path of keys in the tree
|
||||
(define (tree-set! tr path value)
|
||||
(if (null? path)
|
||||
(set-tree-value! tr value)
|
||||
(let ((child (tree-child tr (car path))))
|
||||
(if child
|
||||
(tree-set! child (cdr path) value)
|
||||
(let ((new-child (make-tree (car path))))
|
||||
(set-tree-children! tr (cons new-child (tree-children tr)))
|
||||
(tree-set! new-child (cdr path) value))))))
|
||||
|
||||
; Get a sub-tree from its path, or #f if not found
|
||||
(define (tree-node tr path)
|
||||
(if (null? path)
|
||||
tr
|
||||
(let ((child (tree-child tr (car path))))
|
||||
(if child
|
||||
(tree-node child (cdr path))
|
||||
#f))))
|
||||
|
||||
; Get a value from its path, or #f if not found
|
||||
(define (tree-ref tr path)
|
||||
(let ((node (tree-node tr path)))
|
||||
(and node (tree-value node))))
|
||||
|
||||
; Get the list of all values along a path, or #f if the path does not exist
|
||||
(define (tree->list tr path [ret (list)])
|
||||
(if (null? path)
|
||||
(reverse (cons (tree-value tr) ret))
|
||||
(let ((child (tree-child tr (car path))))
|
||||
(if child
|
||||
(tree->list child (cdr path) (cons (tree-value tr) ret))
|
||||
#f))))
|
||||
|
||||
; Apply the given function on every node of the tree
|
||||
(define (tree-for-each tr fun)
|
||||
(fun (tree-value tr))
|
||||
(for-each
|
||||
(lambda (c) (tree-for-each c fun))
|
||||
(tree-children tr)))
|
||||
|
||||
; Get the path to the first item whose value checks the predicate
|
||||
(define (tree-find-path tr pred (path (list)))
|
||||
(if (pred (tree-value tr))
|
||||
(cdr (reverse (cons (tree-key tr) path))) ; cdr as the root node key should not be present
|
||||
(findf
|
||||
(lambda (x) x)
|
||||
(map
|
||||
(lambda (c) (tree-find-path c pred (cons (tree-key tr) path)))
|
||||
(tree-children tr)))))
|
||||
|
||||
; Fold the tree into a single value
|
||||
; This works around the fun function who takes two arguments : the value of a node, the list of results of tree-fold applied recursively on all children
|
||||
(define (tree-fold tr fun)
|
||||
(fun
|
||||
(tree-value tr)
|
||||
(map
|
||||
(lambda (x)
|
||||
(tree-fold x fun))
|
||||
(tree-children tr))))
|
||||
|
||||
|
|
@ -0,0 +1,346 @@
|
|||
#lang racket/base
|
||||
|
||||
; Floraverse character generator
|
||||
; Generates a character and transform it into various formats
|
||||
|
||||
(require
|
||||
racket/string
|
||||
"flora/character.rkt"
|
||||
"flora/database.rkt"
|
||||
"flora/calendar.rkt"
|
||||
"flora/gender.rkt"
|
||||
"flora/sex.rkt"
|
||||
"flora/element.rkt"
|
||||
"flora/affinity.rkt"
|
||||
"flora/geography.rkt"
|
||||
"flora/species.rkt"
|
||||
"flora/ability.rkt"
|
||||
"phonagen.rkt"
|
||||
"../lang/english.rkt"
|
||||
"../lang/case.rkt"
|
||||
)
|
||||
|
||||
(provide
|
||||
; Generation of a character description, with a format, and constraints
|
||||
flora-character-generate
|
||||
; Formating functions
|
||||
flora-character->full-html
|
||||
flora-character->tweets
|
||||
)
|
||||
|
||||
(define (flora-character-generate floragen format [constraints (make-hash)])
|
||||
; Generate the character
|
||||
(define character (character-generate floragen constraints))
|
||||
; Output with the format
|
||||
(format character floragen))
|
||||
|
||||
; Formating functions
|
||||
; Format to the full html description as sxml
|
||||
(define (flora-character->full-html chr floragen)
|
||||
; Gender and grammatical words
|
||||
(define gender (character-gender chr))
|
||||
(define plural? (gender-plural? gender))
|
||||
(define subject (gender-subject gender))
|
||||
(define genitive (gender-genitive gender))
|
||||
; Name
|
||||
(define name (character-name chr))
|
||||
; Species name
|
||||
(define sp-name (compute-species-name
|
||||
floragen
|
||||
(character-species-genes chr)
|
||||
(character-species-start chr)
|
||||
(character-species-imited chr)))
|
||||
; Birth
|
||||
(define birthday (character-birthday chr))
|
||||
; Affinity
|
||||
(define affinity (character-affinity chr))
|
||||
; Output
|
||||
`(section
|
||||
(h2 ,(show-name name))
|
||||
(p
|
||||
(h3 "Identity")
|
||||
,(gender-title-abbreviation gender) " "
|
||||
,(show-name name) " "
|
||||
,(english:3rd-person-of "be" plural?) " "
|
||||
,(english:undefined-article (car sp-name)) " " ,(cdr sp-name) ". " (br)
|
||||
,(case:upcase-1st genitive) " name is pronounced "
|
||||
"/" ,(word-pronounciation name) "/. " (br)
|
||||
,(case:upcase-1st subject) " " ,(english:3rd-person-of "live" plural?) " "
|
||||
,(cdr (show-place (character-living-place chr) #t)) ". "
|
||||
(details
|
||||
(summary "Genes")
|
||||
(table
|
||||
(tr
|
||||
(td (strong "Species"))
|
||||
,@(map (lambda (x) `(td ,(car x))) (character-species-genes chr)))
|
||||
(tr
|
||||
(td (strong "Amount"))
|
||||
,@(map (lambda (x) `(td ,(number->string (cdr x)) "%")) (character-species-genes chr)))
|
||||
))
|
||||
)
|
||||
(p
|
||||
(h3 "Birth")
|
||||
,(case:upcase-1st subject) " " ,(english:3rd-person-of "be" plural?) " born "
|
||||
,(sex-name (character-sex chr))
|
||||
" on the " ,(english:ordinal (date+sign-day birthday)) " of " ,(date+sign-month-name birthday) " "
|
||||
,(cdr (show-place (character-birth-place chr) #t)) ". " (br)
|
||||
,(case:upcase-1st genitive) " astrological sign is "
|
||||
(img ((src ,(string-append (flora-generator-path floragen) "/" (date+sign-sign-symbol birthday)))
|
||||
(width "16")
|
||||
(height "16")
|
||||
))
|
||||
" " ,(date+sign-sign-name birthday) ". "
|
||||
)
|
||||
(p
|
||||
(h3 "Affinity")
|
||||
,(case:upcase-1st subject) " " ,(english:3rd-person-of "have" plural?) " "
|
||||
,(element-affinity-description
|
||||
(elements-ref
|
||||
(flora-generator-elements floragen)
|
||||
(signed-element-name (car (affinity-composition affinity))))) ". "
|
||||
(details
|
||||
(summary "Affinity breakdown")
|
||||
,(affinity-composition-table (affinity-composition affinity)))
|
||||
(details
|
||||
(summary "Primary affinity breakdown")
|
||||
,(affinity-composition-table (affinity-non-reduced-composition affinity)))
|
||||
)
|
||||
(p
|
||||
(h3 "Appearance and personnality")
|
||||
; Size
|
||||
,(if (character-size chr)
|
||||
`(span
|
||||
,(case:upcase-1st subject) " " ,(english:3rd-person-of "be" plural?) " "
|
||||
,(character-size chr) " for " ,genitive " species. ")
|
||||
"")
|
||||
; Weight
|
||||
,(if (character-weight chr)
|
||||
`(span
|
||||
,(case:upcase-1st subject) " " ,(english:3rd-person-of "be" plural?) " "
|
||||
,(character-weight chr) ". " (br))
|
||||
"")
|
||||
; Natures
|
||||
,(case:upcase-1st subject) " " ,(english:3rd-person-of "be" plural?) " "
|
||||
,@(english:add-commas (character-natures chr)) ". " (br)
|
||||
; Traits
|
||||
,@(apply append (map (lambda (x) (list x '(br))) (character-traits chr)))
|
||||
; Motto
|
||||
,(case:upcase-1st genitive) " motto is “" ,(character-motto chr) "” "
|
||||
)
|
||||
(p
|
||||
(h3 "Abilities")
|
||||
,@(map
|
||||
(lambda (ab)
|
||||
`(details
|
||||
(summary ,(case:upcase-1st (ability-name ab)))
|
||||
,(ability-description ab)))
|
||||
(character-abilities chr))
|
||||
)
|
||||
,(if (or (character-father chr) (character-mother chr))
|
||||
`(p
|
||||
(h3 "Family")
|
||||
,(if (character-father chr)
|
||||
`(details
|
||||
(summary "Father")
|
||||
,(flora-character->full-html (character-father chr) floragen))
|
||||
"")
|
||||
,(if (character-mother chr)
|
||||
`(details
|
||||
(summary "Mother")
|
||||
,(flora-character->full-html (character-mother chr) floragen))
|
||||
"")
|
||||
)
|
||||
"")
|
||||
))
|
||||
|
||||
; Generation into a series of tweets
|
||||
; Return a hash with the following values:
|
||||
; identity, birth, traits, motto
|
||||
(define (flora-character->tweets chr floragen)
|
||||
; Gender and grammatical words
|
||||
(define gender (character-gender chr))
|
||||
(define plural? (gender-plural? gender))
|
||||
(define subject (gender-subject gender))
|
||||
(define genitive (gender-genitive gender))
|
||||
; Name
|
||||
(define name (character-name chr))
|
||||
; Species name
|
||||
(define sp-name (compute-species-name
|
||||
floragen
|
||||
(character-species-genes chr)
|
||||
(character-species-start chr)
|
||||
(character-species-imited chr)))
|
||||
; Birth
|
||||
(define birthday (character-birthday chr))
|
||||
; Affinity
|
||||
(define affinity (character-affinity chr))
|
||||
;
|
||||
(make-immutable-hash
|
||||
`((identity .
|
||||
,(string-append
|
||||
(gender-title-abbreviation gender) " " (show-name name) " "
|
||||
(english:3rd-person-of "be" plural?) " " (english:with-undefined-article (car sp-name)) " with "
|
||||
(element-affinity-description
|
||||
(elements-ref
|
||||
(flora-generator-elements floragen)
|
||||
(signed-element-name (car (affinity-composition affinity))))) ". "
|
||||
(case:upcase-1st genitive) " name is pronounced "
|
||||
"/" (word-pronounciation name) "/."))
|
||||
(birth .
|
||||
,(string-append
|
||||
(case:upcase-1st subject) " " (english:3rd-person-of "be" plural?) " born "
|
||||
(sex-name (character-sex chr)) " on the " (english:ordinal (date+sign-day birthday)) " of " (date+sign-month-name birthday) " "
|
||||
(car (show-place (character-birth-place chr) #t)) ". "
|
||||
(case:upcase-1st genitive) " astrological sign is " (date+sign-sign-name birthday) "."))
|
||||
(traits . ,(string-join (character-traits chr) " "))
|
||||
(motto .
|
||||
,(string-append
|
||||
(case:upcase-1st genitive) " motto is “" (character-motto chr) "”"))
|
||||
)))
|
||||
|
||||
; Helping functions for the diverse outputs
|
||||
|
||||
; Display a name, and eventually its latin transcription
|
||||
(define (show-name name)
|
||||
(let ((native-name (word-native-transcription name))
|
||||
(latin-name (word-latin-transcription name)))
|
||||
(string-append
|
||||
(case:upcase-1st native-name)
|
||||
(if (equal? native-name latin-name)
|
||||
""
|
||||
(string-append " (" (case:upcase-1st latin-name) ")")))))
|
||||
|
||||
; Species names from genes, as plain text and sxml
|
||||
; Compute the name of the species, as string and sxml pair: (cons str-name sxml-name)
|
||||
; Note: genes are sorted by the more predominent to the less predominent
|
||||
(define (compute-species-name floragen genes starting-species imited-species)
|
||||
; Mimic?
|
||||
(define mimic? (species-mimic? starting-species))
|
||||
; Only keep the species name whose genes are predominent enough
|
||||
(define main-gene-count (cdar genes))
|
||||
(define kept-species-name
|
||||
(map
|
||||
car
|
||||
(filter
|
||||
(lambda (sp-name+count)
|
||||
(>= (* 2 (cdr sp-name+count)) main-gene-count))
|
||||
genes)))
|
||||
; Get name from the kept species
|
||||
; Return a string if a name is found or a list of string
|
||||
(define sp-name
|
||||
(cond
|
||||
( (eq? 1 (length kept-species-name))
|
||||
(car kept-species-name))
|
||||
( (eq? 2 (length kept-species-name))
|
||||
(species-database-find-crossbred-name
|
||||
(flora-generator-species floragen)
|
||||
kept-species-name))
|
||||
( #t
|
||||
kept-species-name)))
|
||||
; Function to show a species name with its link, accept a string or a species
|
||||
(define (with-link sp)
|
||||
(define species
|
||||
(if (string? sp)
|
||||
(species-database-get (flora-generator-species floragen) sp)
|
||||
sp))
|
||||
`(a ((href ,(species-reference-link species))) ,(species-name species)))
|
||||
; Return the result
|
||||
(cond
|
||||
; Mimic of a mix of species - imply the use of imited species genes
|
||||
( (and (list? sp-name) mimic?)
|
||||
(cons
|
||||
; String version
|
||||
(string-append
|
||||
(species-name starting-species)
|
||||
" looking like a mix of "
|
||||
(string-join (english:add-commas sp-name) ""))
|
||||
; Sxml version
|
||||
`(span
|
||||
,(with-link starting-species)
|
||||
" looking like a mix of "
|
||||
,@(english:add-commas
|
||||
(map with-link sp-name)))))
|
||||
; Mimic - use imited species genes
|
||||
( (and mimic? (not (species-mimic-genes-used? starting-species)))
|
||||
(cons
|
||||
; String version
|
||||
(string-append
|
||||
sp-name
|
||||
" "
|
||||
(species-name starting-species))
|
||||
; Sxml version
|
||||
`(span
|
||||
,(with-link sp-name)
|
||||
" "
|
||||
,(with-link starting-species))))
|
||||
; Mimic - use mimic species genes
|
||||
( mimic?
|
||||
(cons
|
||||
; String version
|
||||
(string-append
|
||||
(species-name imited-species)
|
||||
" "
|
||||
(species-name starting-species))
|
||||
; Sxml version
|
||||
`(span
|
||||
,(with-link imited-species)
|
||||
" "
|
||||
,(with-link starting-species))))
|
||||
; Unnamed hybrid of species
|
||||
( (list? sp-name)
|
||||
(cons
|
||||
; String version
|
||||
(string-append
|
||||
"hybrid of "
|
||||
(string-join (english:add-commas sp-name) ""))
|
||||
; Sxml version
|
||||
`(span
|
||||
"hybrid of "
|
||||
,@(english:add-commas
|
||||
(map with-link sp-name)))))
|
||||
; Variety
|
||||
; sp-name corresponds to compatibility-name of starting-species
|
||||
; => use species-name, so that the variety is kept
|
||||
( (and (equal? sp-name (species-compatibility-name starting-species))
|
||||
(species-name starting-species))
|
||||
(cons
|
||||
; String version
|
||||
(species-name starting-species)
|
||||
; Sxml version
|
||||
`(span
|
||||
,(with-link (species-name starting-species)))))
|
||||
; Named species
|
||||
( #t
|
||||
(cons
|
||||
; String version
|
||||
sp-name
|
||||
; Sxml version
|
||||
`(span
|
||||
,(with-link sp-name))))
|
||||
))
|
||||
|
||||
; Affinity composition
|
||||
(define (affinity-composition-table composition)
|
||||
`(table
|
||||
(tr
|
||||
(td (strong "Element"))
|
||||
,@(map (lambda (x) `(td ,(signed-element-name x))) composition))
|
||||
(tr
|
||||
(td (strong "Sign"))
|
||||
,@(map (lambda (x) `(td ,(signed-element-sign x))) composition))
|
||||
(tr
|
||||
(td (strong "Amount"))
|
||||
,@(map (lambda (x) `(td ,(number->string (signed-element-count x)) "%")) composition))
|
||||
))
|
||||
|
||||
; Display a place
|
||||
; As plain text and sxml
|
||||
(define (show-place place in?)
|
||||
(define preposition ((if in? location-type-preposition-in location-type-preposition-near)
|
||||
(place-type place)))
|
||||
(cons
|
||||
; String version
|
||||
(string-append preposition " " (place-name place))
|
||||
; sxml version
|
||||
`(span ,preposition " " (a ((href ,(place-reference-link place))) ,(place-name place)))
|
||||
))
|
||||
|
|
@ -0,0 +1,121 @@
|
|||
#lang racket/base
|
||||
|
||||
; Model and generation of abilities
|
||||
(provide
|
||||
; Ability database operations
|
||||
jsexpr->ability-database
|
||||
ability-database-select
|
||||
; ability structure
|
||||
ability-name
|
||||
ability-description
|
||||
ability-author
|
||||
)
|
||||
|
||||
; Ability structure
|
||||
(struct ability
|
||||
(name
|
||||
description
|
||||
author
|
||||
conditions ; list of conditions to get the ability
|
||||
))
|
||||
|
||||
; Species condition
|
||||
(struct species-condition
|
||||
(species-name
|
||||
gene-threshold
|
||||
automatic?))
|
||||
|
||||
; Non-automatic random limit
|
||||
; Number of faces of the dice used to get an ability
|
||||
; Should be higher than the max number of genes, as the number of genes is used as a threshold to get the ability
|
||||
(define non-automatic-dice 125)
|
||||
|
||||
; Check a species condition
|
||||
(define (species-condition-check spcond species-genes)
|
||||
(define gene (findf
|
||||
(lambda (x)
|
||||
(equal? (species-condition-species-name spcond) (car x)))
|
||||
species-genes))
|
||||
(and
|
||||
gene
|
||||
(<= (species-condition-gene-threshold spcond) (cdr gene))
|
||||
(or (species-condition-automatic? spcond)
|
||||
(< (random non-automatic-dice) (cdr gene))) ; If not automatic, the more gene, the more chance to get it
|
||||
))
|
||||
|
||||
; Affinity condition
|
||||
(struct affinity-condition
|
||||
(element-name
|
||||
automatic?))
|
||||
|
||||
; Check an affinity condition
|
||||
(define (affinity-condition-check afcond affinity-genes)
|
||||
(define gene (findf
|
||||
(lambda (x)
|
||||
(equal? (affinity-condition-element-name afcond) (car x)))
|
||||
affinity-genes))
|
||||
(and
|
||||
gene
|
||||
(or (affinity-condition-automatic? afcond)
|
||||
(< (random non-automatic-dice) (cdr gene))) ; If not automatic, the more gene, the more chance to get it
|
||||
))
|
||||
|
||||
; Convert a jsexpr to an ability condition
|
||||
(define (jsexpr->ability-condition js)
|
||||
(define type (hash-ref js 'type))
|
||||
(cond
|
||||
((equal? type "species")
|
||||
(species-condition
|
||||
(hash-ref js 'species)
|
||||
(hash-ref js 'gene-threshold)
|
||||
(hash-ref js 'automatic?)))
|
||||
((equal? type "affinity")
|
||||
(affinity-condition
|
||||
(hash-ref js 'affinity)
|
||||
(hash-ref js 'automatic?)))
|
||||
(#t
|
||||
(error "Invalid ability condition type: " type))
|
||||
))
|
||||
|
||||
; Check an ability condition
|
||||
(define (ability-condition-check abcond species-genes affinity-composition)
|
||||
(cond
|
||||
((species-condition? abcond)
|
||||
(species-condition-check abcond species-genes))
|
||||
((affinity-condition? abcond)
|
||||
(affinity-condition-check abcond affinity-composition))
|
||||
(#t
|
||||
(error "Not an ability condition: " abcond))))
|
||||
|
||||
; Convert a jsexpr to an ability
|
||||
(define (jsexpr->ability js)
|
||||
(ability
|
||||
(hash-ref js 'name)
|
||||
(hash-ref js 'description)
|
||||
(hash-ref js 'author)
|
||||
(map
|
||||
jsexpr->ability-condition
|
||||
(hash-ref js 'conditions))))
|
||||
|
||||
; Ability database
|
||||
(struct ability-database
|
||||
(abilities ; a list of abilities
|
||||
))
|
||||
|
||||
; Convert a jsexpr to an ability database
|
||||
(define (jsexpr->ability-database js)
|
||||
(ability-database
|
||||
(map
|
||||
jsexpr->ability
|
||||
js)))
|
||||
|
||||
; Select the abilities from the database that match the criterias
|
||||
; Note: species-genes and affinity-composition are in a form of '((name . count) ...), sorted by count
|
||||
(define (ability-database-select db species-genes affinity-composition)
|
||||
(filter
|
||||
(lambda (ab)
|
||||
(findf
|
||||
(lambda (x)
|
||||
(ability-condition-check x species-genes affinity-composition))
|
||||
(ability-conditions ab)))
|
||||
(ability-database-abilities db)))
|
||||
|
|
@ -0,0 +1,190 @@
|
|||
#lang racket/base
|
||||
|
||||
; Dependencies
|
||||
(require
|
||||
racket/list
|
||||
"element.rkt"
|
||||
"../../base-generation/random.rkt"
|
||||
"../../base-generation/distribution.rkt")
|
||||
|
||||
; Export
|
||||
(provide
|
||||
; Construction of affinity
|
||||
make-affinity
|
||||
combine-affinity
|
||||
; To display
|
||||
affinity-composition
|
||||
affinity-non-reduced-composition
|
||||
; Signed elements
|
||||
signed-element-name
|
||||
signed-element-sign
|
||||
signed-element-count
|
||||
)
|
||||
|
||||
; Affinity structure
|
||||
(struct affinity
|
||||
(genes ; List of exact primary signed elements, used for computing genetic transmission
|
||||
non-reduced-composition ; Sorted list of signed elements, with count computed
|
||||
composition)) ; Combined composition, with secondary and tertiary elements
|
||||
|
||||
; Signed elements
|
||||
; Structure used in composition of affinity
|
||||
(struct signed-element
|
||||
(name
|
||||
sign
|
||||
count))
|
||||
|
||||
; Number of genes in the list
|
||||
(define nb-genes 100)
|
||||
|
||||
; Construction of affinity from a distribution of element names
|
||||
; Note: the distribution must contains only primary and secondary elements
|
||||
(define (make-affinity elements elem-dist)
|
||||
(define nb-elements 4)
|
||||
(define nb-occurences 13)
|
||||
(define (random:signed-element elem) (signed-element elem (string-append (if (random:boolean) "+" "-") (substring elem 0 1)) 1))
|
||||
(define genes
|
||||
(take
|
||||
(shuffle
|
||||
(apply
|
||||
append
|
||||
(build-list
|
||||
nb-elements
|
||||
(lambda (_)
|
||||
(define el (elements-ref elements (distribution-generate elem-dist)))
|
||||
(if (combined-element? el)
|
||||
(flatten
|
||||
(make-list
|
||||
nb-occurences
|
||||
(map
|
||||
random:signed-element
|
||||
(combined-element-components el))))
|
||||
(make-list (* 2 nb-occurences) (random:signed-element (element-name el)))
|
||||
)))))
|
||||
nb-genes))
|
||||
(define non-reduced-composition (compute-composition genes))
|
||||
(affinity
|
||||
genes
|
||||
non-reduced-composition
|
||||
(reduce-composition elements non-reduced-composition)))
|
||||
|
||||
; Construction of affinity from two affinities
|
||||
(define (combine-affinity elements aff1 aff2)
|
||||
(define genes
|
||||
(take
|
||||
(shuffle
|
||||
(append
|
||||
(affinity-genes aff1)
|
||||
(affinity-genes aff2)))
|
||||
nb-genes))
|
||||
(define non-reduced-composition (compute-composition genes))
|
||||
(affinity
|
||||
genes
|
||||
non-reduced-composition
|
||||
(reduce-composition elements non-reduced-composition)))
|
||||
|
||||
; Reduce the genes to a list of genes with occurence count
|
||||
(define (compute-composition genes)
|
||||
(define table (make-hash))
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(define cell (cons (signed-element-name x) (signed-element-sign x)))
|
||||
(if (hash-has-key? table cell)
|
||||
(hash-set! table cell (+ 1 (hash-ref table cell)))
|
||||
(hash-set! table cell 1)))
|
||||
genes)
|
||||
(sort-composition
|
||||
(hash-map
|
||||
table
|
||||
(lambda (k v)
|
||||
(signed-element
|
||||
(car k)
|
||||
(cdr k)
|
||||
v)))))
|
||||
|
||||
; Sort and remove the element with null count
|
||||
(define (sort-composition comp)
|
||||
(sort
|
||||
(filter
|
||||
(lambda (x) (> (signed-element-count x) 0))
|
||||
comp)
|
||||
(lambda (x y) (> (signed-element-count x) (signed-element-count y)))))
|
||||
|
||||
|
||||
; Return the combination, or #f if it doesn't exist
|
||||
; Combination will combine the signs in the order of the combination table.
|
||||
(define (combine-element elements a b)
|
||||
(define combination-table (elements-combination-table elements))
|
||||
(cond
|
||||
((hash-has-key? combination-table (list (signed-element-name a) (signed-element-name b)))
|
||||
(signed-element
|
||||
(hash-ref combination-table (list (signed-element-name a) (signed-element-name b)))
|
||||
(string-append (signed-element-sign a) "/" (signed-element-sign b))
|
||||
1))
|
||||
((hash-has-key? combination-table (list (signed-element-name b) (signed-element-name a)))
|
||||
(signed-element
|
||||
(hash-ref combination-table (list (signed-element-name b) (signed-element-name a)))
|
||||
(string-append (signed-element-sign b) "/" (signed-element-sign a))
|
||||
1))
|
||||
(#t #f)))
|
||||
|
||||
; Combine the composition
|
||||
; Algo: if the rest of the input list is not null:
|
||||
; Consider the two first elements of the input list
|
||||
; if combination is possible:
|
||||
; - combine the elements:
|
||||
; * with elements A, B, of occurence count cA, cB (cA >= cB):
|
||||
; * replace in the list the items [(A, c1), (B, cB)] by:
|
||||
; + if A and B are both primary or secondary: [(AB, cB+cB), (A, cA-cB)]
|
||||
; + if A is primary and B secondary: [(AB, cB+cB/2), (A, cA-cB/2)]
|
||||
; + if A is secondary and B primary, and cB <= cA/2: [(AB, 3*cB), (A, cA-2*cB)]
|
||||
; + if A is secondary and B primary, and cB > cA/2: [(AB, cA+cA/2), (B, cB-cA/2)]
|
||||
; - sort the list
|
||||
; else:
|
||||
; - remove the first element from the input list and put it in the result list
|
||||
; Repeat
|
||||
(define (reduce-composition elements comp [result (list)])
|
||||
(define (compute-replacement A B AB)
|
||||
(let ((A-secondary? (combined-element? (elements-ref elements (signed-element-name A))))
|
||||
(B-secondary? (combined-element? (elements-ref elements (signed-element-name B))))
|
||||
(cA (signed-element-count A))
|
||||
(cB (signed-element-count B))
|
||||
)
|
||||
(cond
|
||||
( (eq? A-secondary? B-secondary?)
|
||||
(list
|
||||
(signed-element (signed-element-name AB) (signed-element-sign AB) (+ cB cB))
|
||||
(signed-element (signed-element-name A) (signed-element-sign A) (- cA cB))))
|
||||
( B-secondary?
|
||||
(list
|
||||
(signed-element (signed-element-name AB) (signed-element-sign AB) (+ cB (floor (/ cB 2))))
|
||||
(signed-element (signed-element-name A) (signed-element-sign A) (- cA (floor (/ cB 2))))))
|
||||
( (<= cB (/ cA 2))
|
||||
(list
|
||||
(signed-element (signed-element-name AB) (signed-element-sign AB) (+ cB cB cB))
|
||||
(signed-element (signed-element-name A) (signed-element-sign A) (- cA cB cB))))
|
||||
( #t
|
||||
(list
|
||||
(signed-element (signed-element-name AB) (signed-element-sign AB) (+ cA (floor (/ cA 2))))
|
||||
(signed-element (signed-element-name B) (signed-element-sign B) (- cB (floor (/ cA 2))))))
|
||||
)))
|
||||
(cond
|
||||
((null? comp)
|
||||
(sort-composition result))
|
||||
((null? (cdr comp))
|
||||
(reduce-composition elements (list) (append comp result)))
|
||||
(#t
|
||||
(let* ((a (car comp))
|
||||
(b (cadr comp))
|
||||
(c (combine-element elements a b)))
|
||||
(if c
|
||||
(reduce-composition
|
||||
elements
|
||||
(sort-composition
|
||||
(append (compute-replacement a b c) (cddr comp)))
|
||||
result)
|
||||
(reduce-composition
|
||||
elements
|
||||
(cdr comp)
|
||||
(cons (car comp) result))
|
||||
)))))
|
||||
|
|
@ -0,0 +1,163 @@
|
|||
#lang racket/base
|
||||
|
||||
; Model and generation of birth date
|
||||
(require
|
||||
"../../base-generation/distribution.rkt")
|
||||
|
||||
; Only exported: calendar, date+sign
|
||||
; Other structures are only used internally
|
||||
(provide
|
||||
jsexpr->calendar calendar-generate-date calendar-get-date
|
||||
date+sign-day date+sign-month-name date+sign-month-number date+sign-sign-name date+sign-sign-symbol
|
||||
)
|
||||
|
||||
;;;;
|
||||
; Month structure
|
||||
(struct month
|
||||
(number
|
||||
name
|
||||
days
|
||||
named-after))
|
||||
|
||||
; Construction from json expressions
|
||||
(define (jsexpr->month js)
|
||||
(month
|
||||
(hash-ref js 'number)
|
||||
(hash-ref js 'name)
|
||||
(hash-ref js 'days)
|
||||
(hash-ref js 'named-after)))
|
||||
|
||||
;;;;
|
||||
; Simple date structure
|
||||
(struct simple-date
|
||||
(month
|
||||
day))
|
||||
|
||||
; Simple date comparators
|
||||
; Equal
|
||||
(define (simple-date= d1 d2)
|
||||
(and
|
||||
(eq? (month-number (simple-date-month d1)) (month-number (simple-date-month d2)))
|
||||
(eq? (simple-date-day d1) (simple-date-day d2))))
|
||||
; Inferior
|
||||
(define (simple-date< d1 d2)
|
||||
(let ((m1 (month-number (simple-date-month d1)))
|
||||
(m2 (month-number (simple-date-month d2))))
|
||||
(or
|
||||
(< m1 m2)
|
||||
(and
|
||||
(eq? m1 m2)
|
||||
(< (simple-date-day d1) (simple-date-day d2))))))
|
||||
; Superior
|
||||
(define (simple-date> d1 d2)
|
||||
(let ((m1 (month-number (simple-date-month d1)))
|
||||
(m2 (month-number (simple-date-month d2))))
|
||||
(or
|
||||
(> m1 m2)
|
||||
(and
|
||||
(eq? m1 m2)
|
||||
(> (simple-date-day d1) (simple-date-day d2))))))
|
||||
; Inferior or equal
|
||||
(define (simple-date<= d1 d2)
|
||||
(not (simple-date> d1 d2)))
|
||||
; Superior or equal
|
||||
(define (simple-date>= d1 d2)
|
||||
(not (simple-date< d1 d2)))
|
||||
|
||||
; Construction from json expressions
|
||||
(define (jsexpr->simple-date js months)
|
||||
(simple-date
|
||||
(hash-ref months (hash-ref js 'month))
|
||||
(hash-ref js 'day)))
|
||||
|
||||
;;;;
|
||||
; Astrological sign structure
|
||||
(struct astrological-sign
|
||||
(name
|
||||
symbol
|
||||
from
|
||||
to))
|
||||
|
||||
; Construction from json expressions
|
||||
(define (jsexpr->astrological-sign js months)
|
||||
(astrological-sign
|
||||
(hash-ref js 'name)
|
||||
(hash-ref js 'symbol)
|
||||
(jsexpr->simple-date (hash-ref js 'from) months)
|
||||
(jsexpr->simple-date (hash-ref js 'to) months)))
|
||||
|
||||
;;;;
|
||||
; Date and sign
|
||||
(struct date+sign
|
||||
(month
|
||||
day
|
||||
sign))
|
||||
|
||||
; Accessors on date+sign
|
||||
; Month name
|
||||
(define (date+sign-month-name ds)
|
||||
(month-name (date+sign-month ds)))
|
||||
; Month number
|
||||
(define (date+sign-month-number ds)
|
||||
(month-number (date+sign-month ds)))
|
||||
; Sign name
|
||||
(define (date+sign-sign-name ds)
|
||||
(astrological-sign-name (date+sign-sign ds)))
|
||||
; Sign symbol
|
||||
(define (date+sign-sign-symbol ds)
|
||||
(astrological-sign-symbol (date+sign-sign ds)))
|
||||
|
||||
;;;;
|
||||
; Calendar stucture
|
||||
(struct calendar
|
||||
(months-map ; Map of month index to month
|
||||
months-distribution ; when picking a random date, a distribution is needed to take into account the fact that months may not have the same number of days
|
||||
astrological-signs))
|
||||
|
||||
; Calendar from json-expression
|
||||
(define (jsexpr->calendar js)
|
||||
(define months-list (map jsexpr->month (hash-ref js 'months)))
|
||||
(define months-map (make-hash))
|
||||
(define months-distribution (make-distribution))
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(hash-set! months-map (month-number x) x)
|
||||
(distribution-add-to! months-distribution x (month-days x)))
|
||||
months-list)
|
||||
(define sign-list (map (lambda (j) (jsexpr->astrological-sign j months-map)) (hash-ref js 'astrological-signs)))
|
||||
(calendar
|
||||
months-map
|
||||
months-distribution
|
||||
sign-list))
|
||||
|
||||
; Find the sign from a date
|
||||
(define (calendar-get-sign cal date)
|
||||
(findf
|
||||
(lambda (as)
|
||||
(let ((accross-year? (simple-date< (astrological-sign-to as) (astrological-sign-from as))))
|
||||
(or (and (not accross-year?)
|
||||
(simple-date<= (astrological-sign-from as) date)
|
||||
(simple-date<= date (astrological-sign-to as)))
|
||||
(and accross-year?
|
||||
(or (simple-date<= date (astrological-sign-from as))
|
||||
(simple-date<= (astrological-sign-to as) date ))))))
|
||||
(calendar-astrological-signs cal)))
|
||||
|
||||
; Choose a random date from a calendar
|
||||
; Returns a date+sign
|
||||
(define (calendar-generate-date cal)
|
||||
(define m (distribution-generate (calendar-months-distribution cal))) ; Month
|
||||
(define d (+ 1 (random (month-days m)))) ; Day
|
||||
(date+sign
|
||||
m
|
||||
d
|
||||
(calendar-get-sign cal (simple-date m d))))
|
||||
|
||||
; Get a date from the month number and day number
|
||||
; Returns a date+sign
|
||||
(define (calendar-get-date cal m d)
|
||||
(let ((month (hash-ref (calendar-months-map cal) m)))
|
||||
(date+sign
|
||||
month
|
||||
d
|
||||
(calendar-get-sign cal (simple-date month d)))))
|
||||
|
|
@ -0,0 +1,385 @@
|
|||
#lang racket/base
|
||||
|
||||
; Character structure for the floraverse character generator
|
||||
(require
|
||||
racket/string
|
||||
racket/list
|
||||
"../../base-generation/random.rkt"
|
||||
"../../base-generation/category.rkt"
|
||||
"../../base-generation/distribution.rkt"
|
||||
"database.rkt"
|
||||
"calendar.rkt"
|
||||
"motto.rkt"
|
||||
"gender.rkt"
|
||||
"sex.rkt"
|
||||
"element.rkt"
|
||||
"affinity.rkt"
|
||||
"geography.rkt"
|
||||
"species.rkt"
|
||||
"../phonagen.rkt"
|
||||
"trait.rkt"
|
||||
"ability.rkt"
|
||||
"../../lang/english.rkt"
|
||||
)
|
||||
|
||||
(provide
|
||||
; Generation of a character
|
||||
character-generate
|
||||
; Character accessors
|
||||
character-father
|
||||
character-mother
|
||||
character-birthday
|
||||
character-motto
|
||||
character-natures
|
||||
character-gender
|
||||
character-sex
|
||||
character-affinity
|
||||
character-birth-place
|
||||
character-living-place
|
||||
character-species-genes
|
||||
character-species-start
|
||||
character-species-imited
|
||||
character-name
|
||||
character-traits
|
||||
character-abilities
|
||||
character-size
|
||||
character-weight
|
||||
)
|
||||
|
||||
; Character structure
|
||||
(struct character
|
||||
(internal-natures-dict ; Dictionnary of natures - for internal use only
|
||||
internal-traits-word-dict ; Dictionnary of words used in traits - for internal use only
|
||||
internal-language ; Language used for generating the name - for internal use only
|
||||
internal-traits ; Dictionnary of traits - for internal use only
|
||||
father ; Father of character
|
||||
mother ; Mother of character
|
||||
birthday ; Date of birth, as a date+sign
|
||||
motto ; Motto
|
||||
natures ; List of main natures
|
||||
sex ; Sex of character
|
||||
gender ; Gender of character
|
||||
affinity ; Elemental affinity of character
|
||||
birth-place ; Place of birth
|
||||
living-place ; Place where the character lives
|
||||
species-genes ; List of species genes of the character
|
||||
species-start ; The starting point for species generation
|
||||
species-imited ; For mimic species, the imited species
|
||||
name ; Name of the character
|
||||
traits ; List of traits
|
||||
abilities ; List of abilities
|
||||
size ; Size of character.
|
||||
weight ; Weight of character.
|
||||
))
|
||||
|
||||
; Full reduction of affinity: merge all the affinity with the same elements into one, to make a gene-like list with element-name + count
|
||||
(define (affinity-reduce-for-ability affinity)
|
||||
(define composition (make-hash))
|
||||
(for-each
|
||||
(lambda (elem)
|
||||
(hash-set!
|
||||
composition
|
||||
(signed-element-name elem)
|
||||
(+ (signed-element-count elem)
|
||||
(hash-ref composition (signed-element-name elem) 0))))
|
||||
(affinity-composition affinity))
|
||||
(hash->list composition))
|
||||
|
||||
; Generate a gene list
|
||||
(define (generate-species-genes starting-species imited-species)
|
||||
(define mimic? (species-mimic? starting-species))
|
||||
(define mimic-genes-used? (species-mimic-genes-used? starting-species))
|
||||
(define compatibility-name (species-compatibility-name imited-species))
|
||||
(cond
|
||||
; Mimic using the genes of the mimic species and not those of the imited species
|
||||
( (and mimic? mimic-genes-used?)
|
||||
(list (cons (species-compatibility-name starting-species) 100)))
|
||||
; Crossbreed case
|
||||
( (list? compatibility-name)
|
||||
(map
|
||||
(lambda (x) (cons x 50))
|
||||
compatibility-name))
|
||||
; Non-crossbreed
|
||||
( #t
|
||||
(list (cons compatibility-name 100)))))
|
||||
|
||||
; Size generator
|
||||
(define (generate-size)
|
||||
(let ((numeric (random:normal)))
|
||||
(cond
|
||||
((> numeric 1.35) "huge")
|
||||
((> numeric 0.67) "large")
|
||||
((> numeric -0.67) #f)
|
||||
((> numeric -1.35) "small")
|
||||
(#t "tiny"))))
|
||||
|
||||
; Weight generator
|
||||
(define (generate-weight)
|
||||
(let ((numeric (random:normal)))
|
||||
(cond
|
||||
((> numeric 1.35) "obese")
|
||||
((> numeric 0.67) "fat")
|
||||
((> numeric 0.15) "plump")
|
||||
((> numeric -0.15) #f)
|
||||
((> numeric -0.67) "slim")
|
||||
((> numeric -1.35) "thin")
|
||||
(#t "emaciated"))))
|
||||
|
||||
; Sex generation
|
||||
(define (generate-sex-name floragen genes)
|
||||
(distribution-generate
|
||||
(distribution-linear-combination
|
||||
(map
|
||||
(lambda (x)
|
||||
(cons
|
||||
(species-sex-distribution
|
||||
(species-database-get (flora-generator-species floragen) (car x)))
|
||||
(cdr x)))
|
||||
genes))))
|
||||
|
||||
; Generate a place
|
||||
(define (generate-place floragen species (place #f))
|
||||
(cond
|
||||
( (and place (< (random 10) 6))
|
||||
place)
|
||||
( (or (species-restricted-to-endemic-areas? species) (< (random 10) 6))
|
||||
(geography-random-subplace
|
||||
(flora-generator-geography floragen)
|
||||
(random:from-list (species-endemic-in species))))
|
||||
(#t
|
||||
(geography-random-subplace (flora-generator-geography floragen) "Floraverse"))
|
||||
))
|
||||
|
||||
; Generate an affinity
|
||||
(define (generate-affinity floragen genes)
|
||||
(make-affinity
|
||||
(flora-generator-elements floragen)
|
||||
(distribution-linear-combination
|
||||
(map
|
||||
(lambda (x)
|
||||
(cons
|
||||
(species-affinity-distribution
|
||||
(species-database-get (flora-generator-species floragen) (car x)))
|
||||
(cdr x)))
|
||||
genes))))
|
||||
|
||||
; Generate the parent couple for a given species
|
||||
; Return a pair of species, first is father, second is mother
|
||||
(define (generate-parent-species floragen starting-species imited-species)
|
||||
(define reproduction (species-reproduction starting-species))
|
||||
;
|
||||
(cond
|
||||
; Artifacts are built => no parents
|
||||
((eq? reproduction 'artifact)
|
||||
(cons #f #f))
|
||||
; Asexual reproduction => mother only, from the asexual-parent-species, sex is set to #f
|
||||
((eq? reproduction 'asexual)
|
||||
(define parent-species
|
||||
(species-database-get
|
||||
(flora-generator-species floragen)
|
||||
(random:from-list (species-asexual-parent-species starting-species))))
|
||||
(cons #f parent-species))
|
||||
; Mimic using imited species genes - one of two possible case, so 50% to trigger
|
||||
((and (species-mimic? starting-species)
|
||||
(not (species-mimic-genes-used? starting-species)) (random:boolean))
|
||||
; one of the parent is of the mimic species, the other is of the imited species
|
||||
(if (random:boolean)
|
||||
(cons imited-species starting-species)
|
||||
(cons starting-species imited-species)))
|
||||
; Crossbred species, case 1: parents are from the two compatible species
|
||||
((and (random:boolean) (list? (species-compatibility-name starting-species)))
|
||||
(define compat-name
|
||||
(map
|
||||
(lambda (x) (species-database-get (flora-generator-species floragen) x))
|
||||
(species-compatibility-name starting-species)))
|
||||
(if (random:boolean)
|
||||
(cons (car compat-name) (cadr compat-name))
|
||||
(cons (cadr compat-name) (car compat-name))))
|
||||
; Sexual reproduction, case 1 / Crossbred species, case 2: parents are both of the same species
|
||||
((or (random:boolean) (list? (species-compatibility-name starting-species)))
|
||||
(cons starting-species starting-species))
|
||||
; Sexual reproduction, case 2: parents are of compatible species
|
||||
(#t
|
||||
; All possible parents
|
||||
(define all-possible-parents (species-database-all-possible-parents (flora-generator-species floragen) starting-species))
|
||||
(cons
|
||||
(random:from-list all-possible-parents)
|
||||
(random:from-list all-possible-parents)))
|
||||
))
|
||||
|
||||
; Combine genes from two list of genes
|
||||
(define (combine-genes genome1 genome2)
|
||||
; Distribution for genome1
|
||||
(define d1 (apply distribution genome1))
|
||||
(define d2 (apply distribution genome2))
|
||||
; Generate 60 genes from each distribution, append, shuffle, and drop the 20 first elements
|
||||
(define lst-genes
|
||||
(list-tail
|
||||
(shuffle
|
||||
(append
|
||||
(build-list 60 (lambda (_) (distribution-generate d1)))
|
||||
(build-list 60 (lambda (_) (distribution-generate d2)))))
|
||||
20))
|
||||
; Simplify the list into a list of (species . count)
|
||||
; Use a distribution to do this
|
||||
(define d (distribution))
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(distribution-add-to! d x))
|
||||
lst-genes)
|
||||
(hash->list (distribution-items d)))
|
||||
|
||||
; Mother sex for a species
|
||||
(define (mother-sex floragen sp)
|
||||
; Generate from the sex distribution with only the sexes that are mother
|
||||
(define d
|
||||
(distribution-filter
|
||||
(species-sex-distribution sp)
|
||||
(lambda (x)
|
||||
(sex-mother? (sexes-ref (flora-generator-sexes floragen) x)))))
|
||||
; If d is empty, take a sex from the species-sex-distribution
|
||||
(distribution-generate
|
||||
(if (distribution-empty? d) (species-sex-distribution sp) d)))
|
||||
|
||||
; Father sex for a species
|
||||
(define (father-sex floragen sp)
|
||||
; Generate from the sex distribution with only the sexes that are father
|
||||
(define d
|
||||
(distribution-filter
|
||||
(species-sex-distribution sp)
|
||||
(lambda (x)
|
||||
(define mother? (sex-mother? (sexes-ref (flora-generator-sexes floragen) x)))
|
||||
(or (not mother?) (eq? 'maybe mother?)))))
|
||||
; If d is empty, take a sex from the species-sex-distribution
|
||||
(distribution-generate
|
||||
(if (distribution-empty? d) (species-sex-distribution sp) d)))
|
||||
|
||||
; Generator
|
||||
; Generate a character from a hash of constraints
|
||||
(define (character-generate floragen [constraints (make-immutable-hash)])
|
||||
(define asked-language (hash-ref constraints 'language #f))
|
||||
(define starting-species
|
||||
(or
|
||||
(hash-ref constraints 'species #f)
|
||||
(species-database-random (flora-generator-species floragen) species-generable-as-character?)))
|
||||
(define mimic? (species-mimic? starting-species))
|
||||
(define imited-species
|
||||
(if mimic?
|
||||
(species-database-random (flora-generator-species floragen) (species-mimic-method starting-species))
|
||||
starting-species))
|
||||
; Generate parents if needed
|
||||
(define generate-ascendents? (< 0 (hash-ref constraints 'nb-ascendents 0)))
|
||||
(define parent-species (if generate-ascendents?
|
||||
(generate-parent-species floragen starting-species imited-species)
|
||||
(cons #f #f)))
|
||||
(define father (and (car parent-species)
|
||||
(character-generate
|
||||
floragen
|
||||
(make-immutable-hash
|
||||
`((species . ,(car parent-species))
|
||||
(nb-ascendents . ,(- (hash-ref constraints 'nb-ascendents 1) 1))
|
||||
(sex . ,(father-sex floragen (car parent-species)))
|
||||
(language . ,asked-language)
|
||||
)))))
|
||||
(define mother (and (cdr parent-species)
|
||||
(character-generate
|
||||
floragen
|
||||
(make-immutable-hash
|
||||
`((species . ,(cdr parent-species))
|
||||
(nb-ascendents . ,(- (hash-ref constraints 'nb-ascendents 1) 1))
|
||||
(sex . ,(mother-sex floragen (cdr parent-species)))
|
||||
(language . ,asked-language)
|
||||
)))))
|
||||
; Generate species genes
|
||||
(define unsorted-genes (or (and father mother (combine-genes (character-species-genes mother) (character-species-genes father)))
|
||||
(generate-species-genes starting-species imited-species)))
|
||||
(define species-genes (sort unsorted-genes (lambda (x y) (> (cdr x) (cdr y)))))
|
||||
; Generate everything else
|
||||
(define sex (sexes-ref
|
||||
(flora-generator-sexes floragen)
|
||||
(hash-ref
|
||||
constraints
|
||||
'sex
|
||||
(generate-sex-name floragen species-genes))))
|
||||
(define gender (genders-ref (flora-generator-genders floragen) (sex-generate-gender-name sex)))
|
||||
(define birth-place (or (and father (random:boolean) (character-living-place father))
|
||||
(and mother (random:boolean) (character-living-place mother))
|
||||
(generate-place floragen starting-species)))
|
||||
(define language (or (and asked-language (member asked-language (phonagen-generator-ids (flora-generator-name floragen))) asked-language)
|
||||
(and father (random:boolean) (character-internal-language father))
|
||||
(and mother (random:boolean) (character-internal-language mother))
|
||||
(random:from-list (phonagen-generator-ids (flora-generator-name floragen)))))
|
||||
(define nature-dict (random:hash-combine
|
||||
(or (and father (character-internal-natures-dict father)) (make-hash))
|
||||
(or (and mother (character-internal-natures-dict mother)) (make-hash))
|
||||
(category-generate-dictionary (flora-generator-natures floragen))))
|
||||
(define word-dict (random:hash-combine
|
||||
(or (and father (character-internal-traits-word-dict father)) (make-hash))
|
||||
(or (and mother (character-internal-traits-word-dict mother)) (make-hash))
|
||||
(category-generate-dictionary (flora-generator-word-lists floragen))))
|
||||
(define traits-dict (random:hash-combine
|
||||
(or (and father (character-internal-traits father)) (make-hash))
|
||||
(or (and mother (character-internal-traits mother)) (make-hash))
|
||||
(traits-generate (flora-generator-traits floragen))))
|
||||
(define affinity (generate-affinity floragen species-genes))
|
||||
;
|
||||
(character
|
||||
; Internal nature dict
|
||||
nature-dict
|
||||
; Internal word dict
|
||||
word-dict
|
||||
; Internal language
|
||||
language
|
||||
; Internal traits dict
|
||||
traits-dict
|
||||
; Father
|
||||
father
|
||||
; Mother
|
||||
mother
|
||||
; Birthday
|
||||
(calendar-generate-date (flora-generator-calendar floragen))
|
||||
; Motto
|
||||
(motto-generate (flora-generator-mottos floragen))
|
||||
; Natures
|
||||
(random:sublist (hash-values nature-dict) (+ 2 (random 3)))
|
||||
; Sex
|
||||
sex
|
||||
; Gender
|
||||
gender
|
||||
; Affinity
|
||||
affinity
|
||||
; Birth place
|
||||
birth-place
|
||||
; Living place
|
||||
(generate-place floragen starting-species birth-place)
|
||||
; Species genes
|
||||
species-genes
|
||||
; Starting species
|
||||
starting-species
|
||||
; Imited species
|
||||
imited-species
|
||||
; Name
|
||||
(phonagen-generate (flora-generator-name floragen) language)
|
||||
; Traits
|
||||
(map
|
||||
(lambda (x)
|
||||
(trait->string
|
||||
x
|
||||
gender
|
||||
word-dict
|
||||
(flora-generator-natures floragen)
|
||||
(flora-generator-species floragen)
|
||||
(flora-generator-geography floragen)))
|
||||
(random:sublist (hash-values traits-dict) (+ 3 (random 3))))
|
||||
; Abilities
|
||||
(random:sublist
|
||||
(ability-database-select
|
||||
(flora-generator-abilities floragen)
|
||||
species-genes
|
||||
(affinity-reduce-for-ability affinity))
|
||||
5)
|
||||
; Size
|
||||
(generate-size)
|
||||
; Weight
|
||||
(generate-weight)
|
||||
))
|
||||
|
|
@ -0,0 +1,75 @@
|
|||
#lang racket/base
|
||||
|
||||
; Floraverse generator database
|
||||
(require
|
||||
json
|
||||
"../../base-generation/category.rkt"
|
||||
"calendar.rkt"
|
||||
"motto.rkt"
|
||||
"gender.rkt"
|
||||
"sex.rkt"
|
||||
"element.rkt"
|
||||
"geography.rkt"
|
||||
"species.rkt"
|
||||
"../phonagen.rkt"
|
||||
"trait.rkt"
|
||||
"ability.rkt"
|
||||
)
|
||||
|
||||
(provide
|
||||
; Build generator from a path containing the different json files
|
||||
make-flora-generator
|
||||
; Accessors to various parts of the generator
|
||||
flora-generator-path
|
||||
flora-generator-calendar
|
||||
flora-generator-mottos
|
||||
flora-generator-natures
|
||||
flora-generator-word-lists
|
||||
flora-generator-genders
|
||||
flora-generator-sexes
|
||||
flora-generator-elements
|
||||
flora-generator-geography
|
||||
flora-generator-species
|
||||
flora-generator-name
|
||||
flora-generator-traits
|
||||
flora-generator-abilities
|
||||
)
|
||||
|
||||
; Flora generator structure
|
||||
(struct flora-generator
|
||||
(path ; path to the database directory
|
||||
calendar ; calendar informations, to generate dates
|
||||
mottos ; Motto generator
|
||||
natures ; Nature generator
|
||||
word-lists ; Generator of words from lists
|
||||
genders ; Dictionnary of genders
|
||||
sexes ; Dictionnary of sexes
|
||||
elements ; Dictionnary of magic elements
|
||||
geography ; Geographical informations
|
||||
species ; Species information
|
||||
name ; Name generator
|
||||
traits ; Traits generator
|
||||
abilities ; Abilities information
|
||||
))
|
||||
|
||||
; Helper to retrieve the files
|
||||
(define (load-json-file prefix data-dir file-name)
|
||||
(call-with-input-file (string-append prefix data-dir "/" file-name) read-json))
|
||||
|
||||
; Build flora generator from json files
|
||||
(define (make-flora-generator prefix data-dir phonagen-file)
|
||||
(flora-generator
|
||||
data-dir
|
||||
(jsexpr->calendar (load-json-file prefix data-dir "calendar.json"))
|
||||
(jsexpr->motto-generator (load-json-file prefix data-dir "mottos.json"))
|
||||
(jsexpr->category-generator (load-json-file prefix data-dir "natures.json"))
|
||||
(jsexpr->category-generator (load-json-file prefix data-dir "word-lists.json"))
|
||||
(jsexpr->genders (load-json-file prefix data-dir "genders.json"))
|
||||
(jsexpr->sexes (load-json-file prefix data-dir "sexes.json"))
|
||||
(jsexpr->elements (load-json-file prefix data-dir "elements.json"))
|
||||
(jsexpr->geography (load-json-file prefix data-dir "geography.json"))
|
||||
(jsexpr->species-database (load-json-file prefix data-dir "species.json"))
|
||||
(jsexpr->phonagen (call-with-input-file (string-append prefix phonagen-file) read-json))
|
||||
(jsexpr->traits-generator (load-json-file prefix data-dir "traits.json"))
|
||||
(jsexpr->ability-database (load-json-file prefix data-dir "abilities.json"))
|
||||
))
|
||||
|
|
@ -0,0 +1,79 @@
|
|||
#lang racket/base
|
||||
|
||||
; Model and generation of elemental affinities
|
||||
(provide
|
||||
; elements collection functions
|
||||
jsexpr->elements
|
||||
elements-ref elements-combination-table
|
||||
; Element structure accessors
|
||||
element-name element-affinity-description
|
||||
element-nouns element-adjectives
|
||||
combined-element? combined-element-components
|
||||
)
|
||||
|
||||
; Element structure
|
||||
(struct element
|
||||
(name
|
||||
affinity-description
|
||||
nouns
|
||||
adjectives))
|
||||
|
||||
; Combined element structure
|
||||
(struct combined-element element
|
||||
(components))
|
||||
|
||||
; Construction of an Element from a json expression
|
||||
(define (jsexpr->element js)
|
||||
(element
|
||||
(hash-ref js 'name)
|
||||
(hash-ref js 'affinity-description)
|
||||
(hash-ref js 'related-nouns)
|
||||
(hash-ref js 'related-adjectives)))
|
||||
|
||||
; Construction of a Combined Element from a json expression
|
||||
(define (jsexpr->combined-element js)
|
||||
(define result (hash-ref js 'result))
|
||||
(combined-element
|
||||
(hash-ref result 'name)
|
||||
(hash-ref result 'affinity-description)
|
||||
(hash-ref result 'related-nouns)
|
||||
(hash-ref result 'related-adjectives)
|
||||
(hash-ref js 'components)))
|
||||
|
||||
; A collection of elements
|
||||
(struct elements
|
||||
(none
|
||||
primary
|
||||
secondary
|
||||
tertiary
|
||||
all
|
||||
combination-table))
|
||||
|
||||
; From json
|
||||
(define (jsexpr->elements js)
|
||||
(define ret
|
||||
(elements
|
||||
(jsexpr->element (hash-ref js 'none))
|
||||
(map jsexpr->element (hash-ref js 'primary))
|
||||
(map jsexpr->combined-element (hash-ref js 'secondary))
|
||||
(map jsexpr->combined-element (hash-ref js 'tertiary))
|
||||
(make-hash)
|
||||
(make-hash)))
|
||||
; Populate the table of all elements
|
||||
(define (add-element el)
|
||||
(hash-set! (elements-all ret) (element-name el) el))
|
||||
(add-element (elements-none ret))
|
||||
(for-each add-element (elements-primary ret))
|
||||
(for-each add-element (elements-secondary ret))
|
||||
(for-each add-element (elements-tertiary ret))
|
||||
; Populate the table of combinations
|
||||
(define (add-combinations el)
|
||||
(hash-set! (elements-combination-table ret) (combined-element-components el) (element-name el)))
|
||||
(for-each add-combinations (elements-secondary ret))
|
||||
(for-each add-combinations (elements-tertiary ret))
|
||||
;
|
||||
ret)
|
||||
|
||||
; Get an element from its name
|
||||
(define (elements-ref elms name)
|
||||
(hash-ref (elements-all elms) name))
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
#lang racket/base
|
||||
|
||||
; Model and generation of genders
|
||||
(provide
|
||||
; Gender collection functions
|
||||
jsexpr->genders
|
||||
genders-ref
|
||||
; Gender structure accessors
|
||||
gender-name gender-title gender-title-abbreviation
|
||||
gender-subject gender-object gender-genitive gender-reflexive
|
||||
gender-plural?
|
||||
)
|
||||
|
||||
; Gender structure
|
||||
(struct gender
|
||||
(name
|
||||
title
|
||||
title-abbreviation
|
||||
subject
|
||||
object
|
||||
genitive
|
||||
reflexive
|
||||
plural?))
|
||||
|
||||
; Gender collection constructor
|
||||
(define (jsexpr->genders js)
|
||||
(define ret (make-hash))
|
||||
(map
|
||||
(lambda (x)
|
||||
(define name (hash-ref x 'name))
|
||||
(hash-set! ret name
|
||||
(gender
|
||||
name
|
||||
(hash-ref x 'title)
|
||||
(hash-ref x 'title-abbreviation)
|
||||
(hash-ref x 'subject)
|
||||
(hash-ref x 'object)
|
||||
(hash-ref x 'genitive)
|
||||
(hash-ref x 'reflexive)
|
||||
(hash-ref x 'plural?))))
|
||||
js)
|
||||
ret)
|
||||
|
||||
; Get a gender by its name
|
||||
(define (genders-ref gnd name)
|
||||
(hash-ref gnd name))
|
||||
|
|
@ -0,0 +1,113 @@
|
|||
#lang racket/base
|
||||
|
||||
; Model and generation of locations like living places or birth places
|
||||
|
||||
; Dependencies
|
||||
(require
|
||||
"../../collection/tree.rkt"
|
||||
"../../base-generation/random.rkt")
|
||||
|
||||
; Exported functions
|
||||
(provide
|
||||
; Location type
|
||||
location-type-name
|
||||
location-type-preposition-in
|
||||
location-type-preposition-near
|
||||
; Locations
|
||||
place-name
|
||||
place-reference-link
|
||||
place-type
|
||||
; Geography structure
|
||||
jsexpr->geography
|
||||
geography-get-place
|
||||
geography-random-subplace
|
||||
)
|
||||
|
||||
; Structure of type of location
|
||||
(struct location-type
|
||||
(name
|
||||
preposition-in
|
||||
preposition-near))
|
||||
|
||||
; Structure of a location
|
||||
(struct place
|
||||
(name
|
||||
reference-link
|
||||
type
|
||||
restricted?))
|
||||
|
||||
; Geography structure
|
||||
(struct geography
|
||||
(location-types ; table of location types
|
||||
place-tree)) ; tree of places
|
||||
|
||||
; Construction from JSON
|
||||
; Location type
|
||||
(define (jsexpr->location-type js)
|
||||
(location-type
|
||||
(hash-ref js 'name)
|
||||
(hash-ref js 'preposition-in)
|
||||
(hash-ref js 'preposition-near)))
|
||||
|
||||
; Location
|
||||
(define (jsexpr->place js location-types (parent-reference-link #f))
|
||||
(place
|
||||
(hash-ref js 'name)
|
||||
(hash-ref js 'reference-link parent-reference-link)
|
||||
(hash-ref location-types (hash-ref js 'type))
|
||||
(hash-ref js 'restricted? #f)))
|
||||
|
||||
; Tree node
|
||||
(define (jsexpr->place-node js location-types (parent-reference-link #f))
|
||||
(define value (jsexpr->place js location-types parent-reference-link))
|
||||
(tree
|
||||
(hash-ref js 'name)
|
||||
value
|
||||
(map
|
||||
(lambda (x)
|
||||
(jsexpr->place-node x location-types (place-reference-link value)))
|
||||
(hash-ref js 'locations (list)))))
|
||||
|
||||
; Geography
|
||||
(define (jsexpr->geography js)
|
||||
; Fill location types
|
||||
(define location-types (make-hash))
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(define type (jsexpr->location-type x))
|
||||
(hash-set! location-types (location-type-name type) type))
|
||||
(hash-ref js 'location-types))
|
||||
;
|
||||
(geography
|
||||
location-types
|
||||
(jsexpr->place-node (hash-ref js 'places) location-types)
|
||||
))
|
||||
|
||||
; Find a place by its name
|
||||
; Returns the path to the place or #f if it does not exists
|
||||
(define (geography-find-place geo loc-name)
|
||||
(tree-find-path
|
||||
(geography-place-tree geo)
|
||||
(lambda (loc)
|
||||
(equal? loc-name (place-name loc)))))
|
||||
|
||||
; Get a place from its name or #f if it does not exists
|
||||
(define (geography-get-place geo loc-name)
|
||||
(tree-ref
|
||||
(geography-place-tree geo)
|
||||
(geography-find-place geo loc-name)))
|
||||
|
||||
; Get a subplace of a place from its name
|
||||
(define (geography-random-subplace geo loc-name)
|
||||
(define (next-place node)
|
||||
(define children
|
||||
(filter
|
||||
(lambda (x) (not (place-restricted? (tree-value x))))
|
||||
(tree-children node)))
|
||||
(if (null? children)
|
||||
(tree-value node)
|
||||
(next-place (random:from-list children))))
|
||||
(next-place
|
||||
(tree-node
|
||||
(geography-place-tree geo)
|
||||
(geography-find-place geo loc-name))))
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
#lang racket/base
|
||||
|
||||
(require
|
||||
"../../base-generation/random.rkt"
|
||||
"../../lang/case.rkt")
|
||||
|
||||
; Model and generation of mottos
|
||||
(provide
|
||||
jsexpr->motto-generator motto-generate)
|
||||
|
||||
; Motto generator structure
|
||||
(struct motto-generator
|
||||
(prefix
|
||||
prefixable
|
||||
unprefixable))
|
||||
|
||||
; Build a motto generator structure from a json expression
|
||||
(define (jsexpr->motto-generator js)
|
||||
(motto-generator
|
||||
(hash-ref js 'prefix)
|
||||
(hash-ref js 'prefixable)
|
||||
(hash-ref js 'unprefixable)))
|
||||
|
||||
; Generate a motto
|
||||
(define (motto-generate gen)
|
||||
(if (random:boolean)
|
||||
(random:from-list (motto-generator-unprefixable gen))
|
||||
(case:upcase-1st
|
||||
(string-append
|
||||
(random:from-list (motto-generator-prefix gen))
|
||||
(random:from-list (motto-generator-prefixable gen))))))
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
#lang racket/base
|
||||
|
||||
(require
|
||||
"../../base-generation/distribution.rkt")
|
||||
|
||||
; Model and generation of sexes
|
||||
(provide
|
||||
; Sexes collection functions
|
||||
jsexpr->sexes
|
||||
sexes-ref
|
||||
; Sex structure accessors
|
||||
sex-name sex-context sex-mother?
|
||||
; Generation of gender
|
||||
sex-generate-gender-name
|
||||
)
|
||||
|
||||
; Sexes structure
|
||||
(struct sex
|
||||
(name
|
||||
context
|
||||
mother?
|
||||
gender-distribution))
|
||||
|
||||
; Generation of gender from sex
|
||||
(define (sex-generate-gender-name sx)
|
||||
(distribution-generate (sex-gender-distribution sx)))
|
||||
|
||||
; Deserialisation from a json object
|
||||
(define (jsexpr->sexes js)
|
||||
(define ret (make-hash))
|
||||
(map
|
||||
(lambda (x)
|
||||
(define name (hash-ref x 'name))
|
||||
(define mother? (hash-ref x 'mother?))
|
||||
(hash-set! ret name
|
||||
(sex
|
||||
name
|
||||
(hash-ref x 'context)
|
||||
(if (equal? mother? "maybe") 'maybe mother?)
|
||||
(jsexpr->distribution/object (hash-ref x 'gender-distribution) #:translator symbol->string))))
|
||||
js)
|
||||
ret)
|
||||
|
||||
; Retrieval from the name
|
||||
(define (sexes-ref sx name)
|
||||
(hash-ref sx name))
|
||||
|
|
@ -0,0 +1,282 @@
|
|||
#lang racket/base
|
||||
|
||||
; Model and generation of species
|
||||
|
||||
(require
|
||||
racket/list
|
||||
racket/set
|
||||
"../../base-generation/distribution.rkt")
|
||||
|
||||
(provide
|
||||
; Field of species
|
||||
species?
|
||||
species-name species-compatibility-name species-reference-link species-endemic-in species-restricted-to-endemic-areas?
|
||||
species-affinity-distribution species-sex-distribution species-reproduction
|
||||
species-asexual-parent-species species-generable-as-character? species-citizen?
|
||||
species-pet? species-wild? species-vegetal? species-mimic? species-mimic-method species-mimic-genes-used?
|
||||
; Functions on a species database structure
|
||||
jsexpr->species-database
|
||||
species-database-get
|
||||
species-database-all
|
||||
species-database-random
|
||||
species-database-find-crossbred-name
|
||||
species-database-all-possible-parents
|
||||
)
|
||||
|
||||
; Species structure
|
||||
(struct species
|
||||
(name ; Name of species
|
||||
compatibility-name ; Name of the species to use when checking in the compatibility tables. A list of names for crossbreed species.
|
||||
reference-link ; link to reference
|
||||
endemic-in ; List of the names of areas the species is endemic
|
||||
restricted-to-endemic-areas? ; Indicate if the species only lives in endemic areas
|
||||
affinity-distribution ; Distribution of affinities
|
||||
sex-distribution ; Distribution of sexes
|
||||
reproduction ; type of reproduction, among: sexual, asexual, artifact
|
||||
asexual-parent-species ; List of the species names that can give birth to this species, in case of asexual reproduction
|
||||
generable-as-character? ; Indicate if the species can be choosen in generation of characters
|
||||
citizen? ; Indicate if the species is considered as citizen
|
||||
pet? ; Indicate if the species is considered as pet
|
||||
wild? ; Indicate if the species is considered as wild animal
|
||||
vegetal? ; Indicate if the species is vegetal
|
||||
mimic? ; Indicate if the species is a mimic species. An associated species must be generated to generate a character
|
||||
mimic-method ; Indicate how the associated species is choosen
|
||||
mimic-genes-used? ; If true, a character of a mimic species use the mimic species in its genes. If false, the character uses the imitated species genes
|
||||
))
|
||||
|
||||
; Species database structure
|
||||
(struct species-database
|
||||
(table
|
||||
crossbreed-table))
|
||||
|
||||
; Key to corresponding method - used for building mimic methods
|
||||
(define keys->method
|
||||
(make-immutable-hash
|
||||
(list
|
||||
(cons 'name species-name)
|
||||
(cons 'reference-link species-reference-link)
|
||||
(cons 'endemic-in species-endemic-in)
|
||||
(cons 'restricted-to-endemic-areas? species-restricted-to-endemic-areas?)
|
||||
; (cons 'affinity species-affinity-distribution)
|
||||
; (cons 'sex species-sex-distribution)
|
||||
(cons 'reproduction species-reproduction)
|
||||
(cons 'asexual-parent-species species-asexual-parent-species)
|
||||
(cons 'generable-as-character? species-generable-as-character?)
|
||||
(cons 'citizen? species-citizen?)
|
||||
(cons 'pet? species-pet?)
|
||||
(cons 'wild? species-wild?)
|
||||
(cons 'vegetal? species-vegetal?)
|
||||
(cons 'mimic? species-mimic?)
|
||||
; (cons 'mimic-method species-mimic-method)
|
||||
(cons 'mimic-genes-used? species-mimic-genes-used?))))
|
||||
|
||||
; Mimic method builder
|
||||
; Returns a function that can be given to species-database-random as choosing predicate
|
||||
(define (jsexpr->mimic-method js (base #f))
|
||||
(define mimic-method (hash-ref js 'species #f))
|
||||
(cond
|
||||
(mimic-method
|
||||
; Create a species predicate from a species function and expected value
|
||||
(define (make-species-pred method value)
|
||||
(lambda (sp)
|
||||
(equal? (method sp) value)))
|
||||
; Create a species predicate from a species function and a list of excluded values
|
||||
; Used when a {"not": [...]} is used as value
|
||||
(define (make-species-excluding-pred method lst-values)
|
||||
(lambda (sp)
|
||||
(not (member (method sp) lst-values))))
|
||||
; List of predicates to apply
|
||||
(define lst-pred
|
||||
(hash-map
|
||||
mimic-method
|
||||
(lambda (k v)
|
||||
(cond
|
||||
; Special case for reproduction as the string values must be converted to symbols
|
||||
( (and (eq? 'reproduction k)
|
||||
(hash? v) (hash-has-key? v 'not))
|
||||
(make-species-excluding-pred (hash-ref keys->method k) (map string->symbol (hash-ref v 'not))))
|
||||
( (eq? 'reproduction k)
|
||||
(make-species-pred (hash-ref keys->method k) (string->symbol v)))
|
||||
; Other cases
|
||||
( (and (hash? v) (hash-has-key? v 'not))
|
||||
(make-species-excluding-pred (hash-ref keys->method k) (hash-ref v 'not)))
|
||||
( #t
|
||||
(make-species-pred (hash-ref keys->method k) v))))))
|
||||
; Built predicate
|
||||
(lambda (sp)
|
||||
(andmap
|
||||
(lambda (fun)
|
||||
(fun sp))
|
||||
lst-pred))
|
||||
)
|
||||
(#t
|
||||
base)))
|
||||
|
||||
; Create a species from a json expression
|
||||
(define (jsexpr->species js (base #f))
|
||||
(species
|
||||
(hash-ref js 'name (and base (species-name base)))
|
||||
(or (and base (species-compatibility-name base)) (hash-ref js 'name #f)) ; The compatibility name is the first species name encountered in the hierarchy of varieties
|
||||
(hash-ref js 'reference-link (and base (species-reference-link base)))
|
||||
(hash-ref js 'endemic-in (and base (species-endemic-in base)))
|
||||
(hash-ref js 'restricted-to-endemic-areas? (and base (species-restricted-to-endemic-areas? base)))
|
||||
(if (hash-has-key? js 'affinity)
|
||||
(jsexpr->distribution/object (hash-ref js 'affinity) #:translator symbol->string)
|
||||
(and base (species-affinity-distribution base)))
|
||||
(if (hash-has-key? js 'sex)
|
||||
(jsexpr->distribution/object (hash-ref js 'sex) #:translator symbol->string)
|
||||
(and base (species-sex-distribution base)))
|
||||
(if (hash-has-key? js 'reproduction)
|
||||
(string->symbol (hash-ref js 'reproduction))
|
||||
(and base (species-reproduction base)))
|
||||
(hash-ref js 'asexual-parent-species (and base (species-asexual-parent-species base)))
|
||||
(hash-ref js 'generable-as-character? (and base (species-generable-as-character? base)))
|
||||
(hash-ref js 'citizen? (and base (species-citizen? base)))
|
||||
(hash-ref js 'pet? (and base (species-pet? base)))
|
||||
(hash-ref js 'wild? (and base (species-wild? base)))
|
||||
(hash-ref js 'vegetal? (and base (species-vegetal? base)))
|
||||
(hash-ref js 'mimic? (and base (species-mimic? base)))
|
||||
(if (hash-has-key? js 'mimic-method)
|
||||
(jsexpr->mimic-method (hash-ref js 'mimic-method) (and base (species-mimic-method base)))
|
||||
(and base (species-mimic-method base)))
|
||||
(hash-ref js 'mimic-genes-used? (and base (species-mimic-genes-used? base)))
|
||||
))
|
||||
|
||||
; Create a crossbreed species from a json expression and the species table
|
||||
(define (jsexpr->crossbreed js species-table)
|
||||
(define (or-combine func a b)
|
||||
(or (func a) (func b)))
|
||||
(define (and-combine func a b)
|
||||
(and (func a) (func b)))
|
||||
(define parents (hash-ref js 'parents))
|
||||
(define parent-1 (hash-ref species-table (car parents)))
|
||||
(define parent-2 (hash-ref species-table (cadr parents)))
|
||||
(define child-js (hash-ref js 'child))
|
||||
(define child-species-name (hash-ref child-js 'name #f)) ; Note: if no name is given, name is set to false
|
||||
; Returned value
|
||||
(define child
|
||||
(species
|
||||
child-species-name
|
||||
(list (species-compatibility-name parent-1) (species-compatibility-name parent-2)) ; Species compatibility is of both parents
|
||||
(hash-ref child-js 'reference-link (or-combine species-reference-link parent-1 parent-2))
|
||||
(hash-ref child-js 'endemic-in (append (species-endemic-in parent-1) (species-endemic-in parent-2)))
|
||||
(hash-ref child-js 'restricted-to-endemic-areas? (or-combine species-restricted-to-endemic-areas? parent-1 parent-2))
|
||||
(if (hash-has-key? child-js 'affinity)
|
||||
(jsexpr->distribution/object (hash-ref child-js 'affinity) #:translator symbol->string)
|
||||
(distribution-linear-combination
|
||||
(list
|
||||
(cons (species-affinity-distribution parent-1) 1)
|
||||
(cons (species-affinity-distribution parent-2) 1))))
|
||||
(if (hash-has-key? child-js 'sex)
|
||||
(jsexpr->distribution/object (hash-ref child-js 'sex) #:translator symbol->string)
|
||||
(distribution-linear-combination
|
||||
(list
|
||||
(cons (species-sex-distribution parent-1) 1)
|
||||
(cons (species-sex-distribution parent-2) 1))))
|
||||
'sexual ; Sexual reproduction is implied by the crossbreed
|
||||
(list) ; asexual-parent-species is only applicable to asexual reproduction
|
||||
(hash-ref child-js 'generable-as-character? (or-combine species-generable-as-character? parent-1 parent-2))
|
||||
(hash-ref child-js 'citizen? (or-combine species-citizen? parent-1 parent-2))
|
||||
(hash-ref child-js 'pet? (or-combine species-pet? parent-1 parent-2))
|
||||
(hash-ref child-js 'wild? (or-combine species-wild? parent-1 parent-2))
|
||||
(hash-ref child-js 'vegetal? (or-combine species-vegetal? parent-1 parent-2))
|
||||
(hash-ref child-js 'mimic? (or-combine species-mimic? parent-1 parent-2))
|
||||
(if (hash-has-key? js 'mimic-method)
|
||||
(jsexpr->mimic-method (hash-ref js 'mimic-method) (or-combine species-mimic-method parent-1 parent-2))
|
||||
(or-combine species-mimic-method parent-1 parent-2))
|
||||
(hash-ref child-js 'mimic-genes-used? (and-combine species-mimic-genes-used? parent-1 parent-2))
|
||||
))
|
||||
; Add the crossbreed species to the table of species if it has a name and that the name is not already present in the species list
|
||||
(when (and child-species-name (not (hash-has-key? species-table child-species-name)))
|
||||
(hash-set! species-table child-species-name child))
|
||||
; Return the species
|
||||
child)
|
||||
|
||||
; Create a species database
|
||||
(define (jsexpr->species-database js-species)
|
||||
; Make the species table
|
||||
(define species-defaults (jsexpr->species (hash-ref js-species 'defaults)))
|
||||
(define species-table (make-hash))
|
||||
(define (process-species js base)
|
||||
(define sp (jsexpr->species js base))
|
||||
(hash-set! species-table (species-name sp) sp)
|
||||
(map
|
||||
(lambda (x) (process-species x sp))
|
||||
(hash-ref js 'varieties (list))))
|
||||
(map
|
||||
(lambda (x) (process-species x species-defaults))
|
||||
(hash-ref js-species 'species))
|
||||
; Make the compatiblity table and crossbreed species if they have a name
|
||||
(define crossbreed-table
|
||||
(make-immutable-hash
|
||||
(map
|
||||
(lambda (x)
|
||||
(cons
|
||||
(list->set (hash-ref x 'parents))
|
||||
(jsexpr->crossbreed x species-table)))
|
||||
(hash-ref js-species 'crossbreeds))))
|
||||
; Return
|
||||
(species-database
|
||||
species-table
|
||||
crossbreed-table))
|
||||
|
||||
; Get a species from its name
|
||||
(define (species-database-get spdb name)
|
||||
(hash-ref (species-database-table spdb) name #f))
|
||||
|
||||
; Get all species satisfying a predicate
|
||||
; Return an empty list if no species satisfy the predicate
|
||||
(define (species-database-all spdb (pred (lambda (sp) #t)))
|
||||
(filter pred (hash-values (species-database-table spdb))))
|
||||
|
||||
; Get a random species satisfying a predicate
|
||||
; Return #f if no species satisfy the predicate
|
||||
(define (species-database-random spdb (pred (lambda (sp) #t)))
|
||||
(define lst (shuffle (species-database-all spdb pred)))
|
||||
(and (not (null? lst)) (car lst)))
|
||||
|
||||
; Get a crossbred name from a list of species names
|
||||
; Return the input if no name is found
|
||||
(define (species-database-find-crossbred-name spdb lst-names)
|
||||
(define crossbred
|
||||
(hash-ref
|
||||
(species-database-crossbreed-table spdb)
|
||||
(list->set lst-names)
|
||||
#f))
|
||||
(or
|
||||
(and crossbred (species-name crossbred))
|
||||
lst-names))
|
||||
|
||||
; Get all the possible parent species from a given species
|
||||
; Based on the compatibility-name, return a list
|
||||
(define (species-database-all-possible-parents spdb sp)
|
||||
; Get the species
|
||||
(define compat-name (species-compatibility-name sp))
|
||||
;
|
||||
(cond
|
||||
; empty list if the species is unknown
|
||||
((not sp) '())
|
||||
; If a crossbread, combine the compatibilities from all base species
|
||||
((list? compat-name)
|
||||
(apply
|
||||
append
|
||||
(map
|
||||
(lambda (x)
|
||||
(species-database-all-possible-parents spdb (species-database-get spdb x)))
|
||||
(species-compatibility-name sp))))
|
||||
; Else => base species
|
||||
(#t
|
||||
; All the species with the same compatibility name
|
||||
(define same-compat
|
||||
(species-database-all
|
||||
spdb
|
||||
(lambda (s) (equal? compat-name (species-compatibility-name s)))))
|
||||
; All the crossbred containing the compatibility-name
|
||||
(define cross-compat
|
||||
(map
|
||||
cdr
|
||||
(filter
|
||||
(lambda (x) (set-member? (car x) compat-name))
|
||||
(hash->list (species-database-crossbreed-table spdb)))))
|
||||
; Append the two lists
|
||||
(append same-compat cross-compat))))
|
||||
|
|
@ -0,0 +1,93 @@
|
|||
#lang racket/base
|
||||
|
||||
; Model and generation of traits
|
||||
(require
|
||||
racket/string
|
||||
"../../base-generation/category.rkt"
|
||||
"../../lang/english.rkt"
|
||||
"../../lang/case.rkt"
|
||||
"gender.rkt"
|
||||
"species.rkt"
|
||||
"geography.rkt")
|
||||
|
||||
(provide
|
||||
jsexpr->traits-generator
|
||||
traits-generate
|
||||
trait->string)
|
||||
|
||||
; Internally, it's a category generator
|
||||
(struct traits-generator
|
||||
(categories))
|
||||
|
||||
(define (jsexpr->traits-generator js)
|
||||
(traits-generator
|
||||
(jsexpr->category-generator js)))
|
||||
|
||||
(define (traits-generate gen)
|
||||
(category-generate-dictionary (traits-generator-categories gen)))
|
||||
|
||||
|
||||
; Return the corresponding accessor of gender
|
||||
(define (gender-accessor name)
|
||||
(case (string->symbol name)
|
||||
((title) gender-title)
|
||||
((title-abbreviation) gender-title-abbreviation)
|
||||
((subject) gender-subject)
|
||||
((object) gender-object)
|
||||
((genitive) gender-genitive)
|
||||
((reflexive) gender-reflexive)
|
||||
(else (error "Invalid gender attribute: " name))))
|
||||
|
||||
; Return the corresponding predicate of species
|
||||
(define (species-predicate name)
|
||||
(case (string->symbol name)
|
||||
((restricted-to-endemic-areas?) species-restricted-to-endemic-areas?)
|
||||
((generable-as-character?) species-generable-as-character?)
|
||||
((citizen?) species-citizen?)
|
||||
((pet?) species-pet?)
|
||||
((wild?) species-wild?)
|
||||
((vegetal?) species-vegetal?)
|
||||
((mimic?) species-mimic?)
|
||||
((mimic-genes-used?) species-mimic-genes-used?)
|
||||
(else (error "Invalid species predicate: " name))))
|
||||
|
||||
; Interpolate a trait into a string
|
||||
; Each trait is a list of tokens
|
||||
; The argument list is:
|
||||
; trait: the trait to interpolate
|
||||
; gender: the gender used to interpolate
|
||||
; wordlist: a dictionary of words to use in interpolation
|
||||
; nature-generator: a category generator
|
||||
; species-database: the database of species
|
||||
; geography-database: the database of geography loacations
|
||||
(define (trait->string trait gender wordlist nature-generator species-database geography-database)
|
||||
; Interpret a token
|
||||
(define (interpret-token token)
|
||||
(cond
|
||||
((string? token)
|
||||
token)
|
||||
((and (hash? token) (hash-has-key? token 'gender))
|
||||
((gender-accessor (hash-ref token 'gender)) gender))
|
||||
((and (hash? token) (hash-has-key? token 'verb))
|
||||
(english:3rd-person-of (hash-ref token 'verb) (gender-plural? gender)))
|
||||
((and (hash? token) (hash-has-key? token 'undefined-article))
|
||||
(english:with-undefined-article (interpret-token (hash-ref token 'undefined-article))))
|
||||
((and (hash? token) (hash-has-key? token 'plural))
|
||||
(english:plural-of (interpret-token (hash-ref token 'plural))))
|
||||
((and (hash? token) (hash-has-key? token 'word))
|
||||
(hash-ref wordlist (string->symbol (hash-ref token 'word))))
|
||||
((and (hash? token) (hash-has-key? token 'species))
|
||||
(species-name (species-database-random species-database (species-predicate (hash-ref token 'species)))))
|
||||
((and (hash? token) (hash-has-key? token 'nature))
|
||||
(category-generate nature-generator))
|
||||
((and (hash? token) (hash-has-key? token 'location))
|
||||
(place-name (geography-random-subplace geography-database "Floraverse")))
|
||||
(#t
|
||||
(error "Invalid token: " token))
|
||||
))
|
||||
(string-append
|
||||
(case:upcase-1st
|
||||
(string-join
|
||||
(map interpret-token trait)
|
||||
" "))
|
||||
"."))
|
||||
|
|
@ -0,0 +1,265 @@
|
|||
#lang racket/base
|
||||
|
||||
; Phonagen generator - Racket implementation
|
||||
; Dependencies
|
||||
(require
|
||||
racket/string
|
||||
racket/list
|
||||
"../base-generation/random.rkt"
|
||||
"../base-generation/markov.rkt"
|
||||
"../base-generation/distribution.rkt"
|
||||
)
|
||||
|
||||
; Exported functions
|
||||
(provide
|
||||
; Generator
|
||||
jsexpr->phonagen
|
||||
phonagen-generate
|
||||
phonagen-generator-ids
|
||||
; Word descriptions
|
||||
word-transcriptions
|
||||
word-pronounciation
|
||||
word-native-transcription
|
||||
word-latin-transcription
|
||||
)
|
||||
|
||||
|
||||
; Phoneme structure
|
||||
(struct phoneme
|
||||
(id ; Id of phoneme
|
||||
description ; Description
|
||||
transcriptions ; Transcriptions of phoneme
|
||||
))
|
||||
|
||||
; Create a phoneme from a json description
|
||||
(define (jsexpr->phoneme js)
|
||||
(phoneme
|
||||
(string->symbol (hash-ref js 'id))
|
||||
(hash-ref js 'description)
|
||||
; Transcriptions: the js object minus 'id and 'description
|
||||
(hash-remove
|
||||
(hash-remove
|
||||
js
|
||||
'id)
|
||||
'description)
|
||||
))
|
||||
|
||||
; Get a transcription of the phoneme from its id
|
||||
(define (phoneme-transcription-get phon tr)
|
||||
(hash-ref (phoneme-transcriptions phon) tr))
|
||||
|
||||
; Phonology
|
||||
(struct phonology
|
||||
(id ; Id of phonology
|
||||
description ; Description
|
||||
transcriptions ; Transcriptions
|
||||
main-transcription ; Main transcription
|
||||
phonemes ; Phonemes
|
||||
))
|
||||
|
||||
; Create a phonology from a json description
|
||||
(define (jsexpr->phonology js)
|
||||
(phonology
|
||||
(string->symbol (hash-ref js 'id))
|
||||
(hash-ref js 'description)
|
||||
(map string->symbol (hash-ref js 'transcriptions))
|
||||
(string->symbol (hash-ref js 'main-transcription))
|
||||
; Phonemes
|
||||
(make-immutable-hash
|
||||
(map
|
||||
(lambda (x)
|
||||
(define phonm (jsexpr->phoneme x))
|
||||
(cons (phoneme-id phonm) phonm))
|
||||
(hash-ref js 'entries)))
|
||||
))
|
||||
|
||||
; Get a phoneme from a phonology from its id
|
||||
(define (phonology-get phon id)
|
||||
(hash-ref (phonology-phonemes phon) id))
|
||||
|
||||
; Generator (chain-based)
|
||||
(struct chain-generator
|
||||
(id ; Id of generator
|
||||
description ; Description
|
||||
phonology ; Phonology used
|
||||
chains ; Markov Generator
|
||||
))
|
||||
|
||||
; Create a chain-generator from a json description
|
||||
(define (jsexpr->chain-generator js)
|
||||
(define chains (make-markov (hash-ref js 'order)))
|
||||
(define (->symbol x) (and (non-empty-string? x) (string->symbol x)))
|
||||
(for-each
|
||||
(lambda (chain)
|
||||
(define input (map ->symbol (hash-ref chain 'input)))
|
||||
(for-each
|
||||
(lambda (output)
|
||||
(markov-add-next-item!
|
||||
chains
|
||||
input
|
||||
(->symbol (hash-ref output 'value))
|
||||
(hash-ref output 'occurences)))
|
||||
(hash-ref chain 'possible-outputs)))
|
||||
(hash-ref js 'chains))
|
||||
(chain-generator
|
||||
(string->symbol (hash-ref js 'id))
|
||||
(hash-ref js 'description)
|
||||
(string->symbol (hash-ref js 'phonology))
|
||||
chains))
|
||||
|
||||
; Generate a list of phoneme id from a chain-generator
|
||||
(define (chain-generator-generate gen)
|
||||
(markov-generate (chain-generator-chains gen)))
|
||||
|
||||
; Generator (rule-based)
|
||||
(struct rule-generator
|
||||
(id ; Id of generator
|
||||
description ; Description
|
||||
phonology ; Phonology used
|
||||
rules ; Rules set
|
||||
))
|
||||
|
||||
; Create a rule-generator from a json description
|
||||
(define (jsexpr->rule-generator js)
|
||||
(rule-generator
|
||||
(string->symbol (hash-ref js 'id))
|
||||
(hash-ref js 'description)
|
||||
(string->symbol (hash-ref js 'phonology))
|
||||
; Rules
|
||||
(make-immutable-hash
|
||||
(map
|
||||
(lambda (rule)
|
||||
(define dist (make-distribution))
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(distribution-add-to!
|
||||
dist
|
||||
(map string->symbol (hash-ref x 'pattern))
|
||||
(hash-ref x 'occurences)))
|
||||
(hash-ref rule 'distribution))
|
||||
(cons (string->symbol (hash-ref rule 'id)) dist))
|
||||
(hash-ref js 'rules)))
|
||||
))
|
||||
|
||||
; Generate a list of phoneme id from a rule-generator
|
||||
(define (rule-generator-generate gen)
|
||||
(define (replace pattern-id)
|
||||
(if (hash-has-key? (rule-generator-rules gen) pattern-id)
|
||||
(map replace (distribution-generate (hash-ref (rule-generator-rules gen) pattern-id)))
|
||||
pattern-id))
|
||||
(flatten (replace 'word)))
|
||||
|
||||
; Make a generator, according to the corresponding type
|
||||
(define (jsexpr->generator js)
|
||||
(case (hash-ref js 'type)
|
||||
(("rules") (jsexpr->rule-generator js))
|
||||
(("chains") (jsexpr->chain-generator js))
|
||||
(else (error "Unsupported generator: " (hash-ref js 'type)))))
|
||||
|
||||
; Get the generator id from a generator
|
||||
(define (generator-id gen)
|
||||
(cond
|
||||
((rule-generator? gen) (rule-generator-id gen))
|
||||
((chain-generator? gen) (chain-generator-id gen))
|
||||
(else (error "Not a generator: " gen))))
|
||||
|
||||
; Get the phonology from a generator
|
||||
(define (generator-phonology gen)
|
||||
(cond
|
||||
((rule-generator? gen) (rule-generator-phonology gen))
|
||||
((chain-generator? gen) (chain-generator-phonology gen))
|
||||
(else (error "Not a generator: " gen))))
|
||||
|
||||
; Generate a list of phoneme id from a generator
|
||||
(define (generator-generate gen)
|
||||
(cond
|
||||
((rule-generator? gen) (rule-generator-generate gen))
|
||||
((chain-generator? gen) (chain-generator-generate gen))
|
||||
(else (error "Not a generator: " gen))))
|
||||
|
||||
; Word structure
|
||||
(struct word
|
||||
(phonemes ; List of phonemes of the words
|
||||
main-transcription ; Id of the main transcription
|
||||
transcriptions ; Map of transcriptions
|
||||
))
|
||||
|
||||
; Generate a word from a generator and a phonology
|
||||
(define (generate-word gen phon)
|
||||
; List of phonemes of the word
|
||||
(define phonemes
|
||||
(map
|
||||
(lambda (x)
|
||||
(phonology-get phon x))
|
||||
(generator-generate gen)))
|
||||
; Return the word
|
||||
(word
|
||||
phonemes
|
||||
(phonology-main-transcription phon)
|
||||
(make-immutable-hash
|
||||
(map
|
||||
(lambda (tr)
|
||||
(cons
|
||||
tr
|
||||
(string-join
|
||||
(map
|
||||
(lambda (x)
|
||||
(phoneme-transcription-get x tr))
|
||||
phonemes)
|
||||
"")))
|
||||
(phonology-transcriptions phon)))
|
||||
))
|
||||
|
||||
; Word->string function
|
||||
(define (word->string wrd tr)
|
||||
(hash-ref (word-transcriptions wrd) tr))
|
||||
|
||||
; Get pronounciation string
|
||||
(define (word-pronounciation wrd)
|
||||
(string-normalize-nfc (word->string wrd 'phoneme)))
|
||||
|
||||
; Get native transcription string
|
||||
(define (word-native-transcription wrd)
|
||||
(word->string wrd (word-main-transcription wrd)))
|
||||
|
||||
; If there is a 'latin language, use it, else return the main transcription
|
||||
(define (word-latin-transcription wrd)
|
||||
(if (hash-has-key? (word-transcriptions wrd) 'latin)
|
||||
(word->string wrd 'latin)
|
||||
(word-native-transcription wrd)))
|
||||
|
||||
; Phonagen generator
|
||||
(struct phonagen
|
||||
(phonologies
|
||||
generators))
|
||||
|
||||
; Create a phonagen generator from a json expression
|
||||
(define (jsexpr->phonagen js)
|
||||
(phonagen
|
||||
; Phonologies
|
||||
(make-immutable-hash
|
||||
(map
|
||||
(lambda (x)
|
||||
(define phon (jsexpr->phonology x))
|
||||
(cons (phonology-id phon) phon))
|
||||
(hash-ref js 'phonologies)))
|
||||
; Generators
|
||||
(make-immutable-hash
|
||||
(map
|
||||
(lambda (x)
|
||||
(define gen (jsexpr->generator x))
|
||||
(cons (generator-id gen) gen))
|
||||
(hash-ref js 'generators)))
|
||||
))
|
||||
|
||||
; Generate a word from a phonagen file, with the generator optionally given
|
||||
(define (phonagen-generate phgen [genid #f])
|
||||
(define gen (or (and genid (hash-ref (phonagen-generators phgen) genid))
|
||||
(cdr (random:from-hash (phonagen-generators phgen)))))
|
||||
(generate-word
|
||||
gen
|
||||
(hash-ref (phonagen-phonologies phgen) (generator-phonology gen))))
|
||||
|
||||
; Get the list of generator ids
|
||||
(define (phonagen-generator-ids phgen)
|
||||
(hash-keys (phonagen-generators phgen)))
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
#lang racket/base
|
||||
|
||||
; Utilities to manipulate case in strings
|
||||
(require
|
||||
racket/string)
|
||||
|
||||
(provide
|
||||
case:upcase-1st)
|
||||
|
||||
; Capitalize the first character of a string
|
||||
; Similar to string-titlecase, but only on the first word
|
||||
(define (case:upcase-1st str)
|
||||
(if (non-empty-string? str)
|
||||
(string-append
|
||||
(string-upcase (substring str 0 1))
|
||||
(substring str 1))
|
||||
""))
|
||||
|
|
@ -0,0 +1,104 @@
|
|||
#lang racket/base
|
||||
|
||||
(require
|
||||
racket/string
|
||||
racket/list
|
||||
(prefix-in srfi13: srfi/13))
|
||||
|
||||
; Various functions for formatting words and sentences written in English.
|
||||
(provide
|
||||
english:ordinal
|
||||
english:3rd-person-of
|
||||
english:undefined-article
|
||||
english:with-undefined-article
|
||||
english:plural-of
|
||||
english:add-commas
|
||||
)
|
||||
|
||||
; Get the ordinal of a given number
|
||||
(define (english:ordinal N)
|
||||
(cond
|
||||
((and (not (eq? 11 (modulo N 100))) (eq? 1 (modulo N 10))) (string-append (number->string N) "st"))
|
||||
((and (not (eq? 12 (modulo N 100))) (eq? 2 (modulo N 10))) (string-append (number->string N) "nd"))
|
||||
((and (not (eq? 13 (modulo N 100))) (eq? 3 (modulo N 10))) (string-append (number->string N) "rd"))
|
||||
(#t (string-append (number->string N) "th"))))
|
||||
|
||||
; Conjugate a verb at the 3rd person (present mode)
|
||||
(define (english:3rd-person-of verb plural?)
|
||||
(cond
|
||||
((equal? "be" verb) (if plural? "are" "is"))
|
||||
((equal? "have" verb) (if plural? "have" "has"))
|
||||
(plural? verb)
|
||||
; Only singular cases
|
||||
((or (string-suffix? verb "s") (string-suffix? verb "sh") (string-suffix? verb "ch")
|
||||
(string-suffix? verb "x") (string-suffix? verb "o"))
|
||||
(string-append verb "es"))
|
||||
((or (string-suffix? verb "ay") (string-suffix? verb "ey") (string-suffix? verb "iy")
|
||||
(string-suffix? verb "oy") (string-suffix? verb "uy"))
|
||||
(string-append verb "s"))
|
||||
((string-suffix? verb "y")
|
||||
(string-append (srfi13:string-drop-right verb 1) "ies"))
|
||||
;;
|
||||
(#t (string-append verb "s"))
|
||||
))
|
||||
|
||||
; Get the undefined article that would prefix a given string
|
||||
(define (english:undefined-article str)
|
||||
(define initial (string-downcase (substring str 0 1)))
|
||||
(if (string-contains? "aeiou" initial)
|
||||
"an"
|
||||
"a"))
|
||||
|
||||
; Return a string prefixed with the corresponding undefined article
|
||||
(define (english:with-undefined-article str)
|
||||
(string-append (english:undefined-article str) " " str))
|
||||
|
||||
; Return the plural variant of a string
|
||||
(define (english:plural-of str)
|
||||
(cond
|
||||
((string-suffix? str "mouse")
|
||||
(string-append (srfi13:string-drop-right str 5) "mice"))
|
||||
((string-suffix? str "louse")
|
||||
(string-append (srfi13:string-drop-right str 5) "lice"))
|
||||
((string-suffix? str "goose")
|
||||
(string-append (srfi13:string-drop-right str 5) "geese"))
|
||||
((string-suffix? str "foot")
|
||||
(string-append (srfi13:string-drop-right str 4) "feet"))
|
||||
((string-suffix? str "tooth")
|
||||
(string-append (srfi13:string-drop-right str 5) "teeth"))
|
||||
((string-suffix? str "man")
|
||||
(string-append (srfi13:string-drop-right str 3) "men"))
|
||||
((or (string-suffix? str "s") (string-suffix? str "sh") (string-suffix? str "ch")
|
||||
(string-suffix? str "x") (string-suffix? str "o"))
|
||||
(string-append str "es"))
|
||||
((or (string-suffix? str "ay") (string-suffix? str "ey") (string-suffix? str "iy")
|
||||
(string-suffix? str "oy") (string-suffix? str "uy"))
|
||||
(string-append str "s"))
|
||||
((string-suffix? str "y")
|
||||
(string-append (srfi13:string-drop-right str 1) "ies"))
|
||||
((string-suffix? str "ff")
|
||||
(string-append (srfi13:string-drop-right str 2) "ves"))
|
||||
((string-suffix? str "f")
|
||||
(string-append (srfi13:string-drop-right str 1) "ves"))
|
||||
((string-suffix? str "fe")
|
||||
(string-append (srfi13:string-drop-right str 2) "ves"))
|
||||
(#t
|
||||
(string-append str "s"))
|
||||
))
|
||||
|
||||
; Add comma between elements of a list, with the last element introduced by "and"
|
||||
(define (english:add-commas lst)
|
||||
(cond
|
||||
; Nothing to add => return the list as is
|
||||
( (>= 1 (length lst))
|
||||
lst)
|
||||
; Add commas
|
||||
(#t
|
||||
(append
|
||||
(foldl
|
||||
(lambda (x result)
|
||||
(append result (list ", " x)))
|
||||
(list (car lst))
|
||||
(drop-right (cdr lst) 1))
|
||||
(list ", and " (last lst)))
|
||||
)))
|
||||
|
|
@ -0,0 +1,205 @@
|
|||
#lang racket/base
|
||||
|
||||
; Floraverse-related pages
|
||||
; Includes the floraverse character generator
|
||||
(require
|
||||
json
|
||||
racket/string
|
||||
racket/date
|
||||
"templates.rkt"
|
||||
"../generators/flora-character.rkt"
|
||||
"../generators/flora/database.rkt"
|
||||
"../generators/flora/calendar.rkt"
|
||||
"../generators/flora/species.rkt"
|
||||
"../generators/phonagen.rkt"
|
||||
"../webcontainer/weblets.rkt"
|
||||
"../webcontainer/weblet-parameter.rkt"
|
||||
"../lang/english.rkt"
|
||||
"../lang/case.rkt")
|
||||
|
||||
(provide
|
||||
pages:not-found
|
||||
pages:floraverse
|
||||
pages:floraverse-character-generator-about
|
||||
pages:floraverse-character-generator
|
||||
pages:floraverse-character-generator-tweet
|
||||
pages:floraverse-calendar)
|
||||
|
||||
; Not found page
|
||||
(define pages:not-found
|
||||
(pages:template
|
||||
#:title "Not found"
|
||||
#:content '(article (p "Sorry, there is nothing here."))
|
||||
#:error-code 404))
|
||||
|
||||
; The generator
|
||||
(define *FloraGenDataDir* "/data/flora-generator-data")
|
||||
(define *FloraGen* (make-flora-generator "./static" *FloraGenDataDir* "/data/phonagen.json"))
|
||||
|
||||
; Floraverse welcome page
|
||||
(define pages:floraverse
|
||||
(pages:template
|
||||
#:title "Home: Generator.Beleth.Pink"
|
||||
#:content
|
||||
'(article
|
||||
(p "As I'm a fan of the " (a ((href "http://floraverse.com")) "Floraverse comic") ", I wrote a generator making characters living in the world of the comic. "
|
||||
"Initially on my main website, I moved the generator and other related Floraverse tools on its own website here, next to the "
|
||||
(a ((href "http://beleth.pink")) "Toy Cat Creator") ". ")
|
||||
)))
|
||||
|
||||
; About the generator
|
||||
(define pages:floraverse-character-generator-about
|
||||
(pages:template
|
||||
#:title "About the Floraverse Character Generator"
|
||||
#:content
|
||||
'(article
|
||||
(section
|
||||
(h3 "Origin")
|
||||
(p "The character generator is inspired by " (a ((href "http://fav.me/d7569je")) "this journal post on deviantArt") ", "
|
||||
"which used the " (a ((href "http://marnok.com/content/_adventure/101npcs.php")) "Marnok's NPC generator") " to generate personality traits. "))
|
||||
(section
|
||||
(h3 "History")
|
||||
(p "The current generator is the fifth iteration of the generator. " (br)
|
||||
"The first version was a written in Java and started as a desktop application, before I added features to run it as a webservice. "
|
||||
"This lead to the creation of the " (a ((href "http://feuforefe.fr")) "Feuforeve.fr website") ", to initially host that generator. " (br)
|
||||
"This generator has since moved to its own website." (br)
|
||||
"The second version was written in Guile Scheme and ran only as a webservice. " (br)
|
||||
"The third version was based on the previous version and was the result of the merger "
|
||||
"of several generators I wrote and hosted on this website into a single project. " (br)
|
||||
"The fourth version was caused by a rewrite of this website in Racket. " (br)
|
||||
"The fifth and current version is an iteration of the previous to separate the data used by the generators from the code. "))
|
||||
(section
|
||||
(h3 "Data")
|
||||
(p "The data used by the generator is available in a "
|
||||
(a ((href "https://projects.feuforeve.fr/Feufochmar/flora-generator-data")) "git repository")
|
||||
", and is mainly written in JSON. "
|
||||
"The file structures are documented in the " (code "README.md") " file. "))
|
||||
(section
|
||||
(h3 "Code")
|
||||
(p "The code of the generator is available along with the code of this website in a "
|
||||
(a ((href "https://projects.feuforeve.fr/Feufochmar/generator.beleth.pink")) "git repository") ". "
|
||||
"It is released under the terms of the GNU General Public License version 2 or any later version (GPLv2+). "
|
||||
"The code is written in " (a ((href "http://racket-lang.org/")) "Racket") ". "))
|
||||
)))
|
||||
|
||||
; Generator page
|
||||
(define *generable-species*
|
||||
(sort
|
||||
(species-database-all (flora-generator-species *FloraGen*) species-generable-as-character?)
|
||||
(lambda (x y) (string<? (species-name x) (species-name y)))))
|
||||
(define *languages*
|
||||
(sort
|
||||
(phonagen-generator-ids (flora-generator-name *FloraGen*))
|
||||
(lambda (x y) (string<? (symbol->string x) (symbol->string y)))))
|
||||
|
||||
(define pages:floraverse-character-generator
|
||||
(pages:template
|
||||
#:title "Floraverse Character Generator"
|
||||
#:content
|
||||
(lambda (param)
|
||||
(define asked-species (weblet-parameter-ref param 'species #f))
|
||||
(define species (and asked-species (species-database-get (flora-generator-species *FloraGen*) asked-species)))
|
||||
(define forced? (equal? "on" (weblet-parameter-ref param 'forced #f)))
|
||||
(define asked-language (weblet-parameter-ref param 'language #f))
|
||||
(define constraints (make-immutable-hash
|
||||
`((species . ,species)
|
||||
(nb-ascendents . ,(if forced? 0 3))
|
||||
(language . ,(and asked-language (string->symbol asked-language)))
|
||||
)))
|
||||
;
|
||||
`(article
|
||||
(section
|
||||
(form
|
||||
((action "/CharacterGenerator"))
|
||||
(label "Species "
|
||||
(select ((name "species"))
|
||||
(option ((value "")) "— random species —")
|
||||
,@(map
|
||||
(lambda (x)
|
||||
(define sp-name (species-name x))
|
||||
`(option ((value ,sp-name)
|
||||
,@(if (equal? sp-name asked-species) '((selected "true")) '()))
|
||||
,sp-name))
|
||||
*generable-species*)
|
||||
))
|
||||
" — "
|
||||
(input ((name "forced")(type "checkbox")
|
||||
,@(if forced? '((checked "true")) '()))
|
||||
"No family (force the species)")
|
||||
(br)
|
||||
(label "Names from "
|
||||
(select ((name "language"))
|
||||
(option ((value "")) "— random word generator —")
|
||||
,@(map
|
||||
(lambda (x)
|
||||
(define str-lang (symbol->string x))
|
||||
`(option ((value ,str-lang)
|
||||
,@(if (equal? str-lang asked-language) '((selected "true")) '()))
|
||||
,str-lang))
|
||||
*languages*)
|
||||
))
|
||||
(br)
|
||||
(button "New character"))
|
||||
)
|
||||
,(flora-character-generate *FloraGen* flora-character->full-html constraints)))))
|
||||
|
||||
; Tweet output, as json
|
||||
(define pages:floraverse-character-generator-tweet
|
||||
(raw-data-weblet
|
||||
#:content-type #"application/json;charset=utf-8"
|
||||
#:body
|
||||
(lambda (param)
|
||||
(jsexpr->bytes
|
||||
(flora-character-generate *FloraGen* flora-character->tweets)))))
|
||||
|
||||
; Calendar Tool
|
||||
(define pages:floraverse-calendar
|
||||
(pages:template
|
||||
#:title "Floraverse Calendar"
|
||||
#:content
|
||||
(lambda (param)
|
||||
(define today (current-date))
|
||||
(define today-flora (calendar-get-date (flora-generator-calendar *FloraGen*) (date-month today) (date-day today)))
|
||||
(define req-date (weblet-parameter-ref param 'date #f))
|
||||
(define split-date (and req-date (string-split req-date "-")))
|
||||
(define req-month (and split-date (eq? 3 (length split-date)) (cadr split-date)))
|
||||
(define req-day (and split-date (eq? 3 (length split-date)) (caddr split-date)))
|
||||
(define match-month (weblet-parameter-ref param 'month #f))
|
||||
(define match-day (weblet-parameter-ref param 'day #f))
|
||||
(define month (or (and req-month (string->number req-month))
|
||||
(and match-month (string->number match-month))))
|
||||
(define day (or (and req-day (string->number req-day))
|
||||
(and match-day (string->number match-day))))
|
||||
(define req-flora
|
||||
(with-handlers ([exn:fail? (lambda (v) #f)])
|
||||
(calendar-get-date (flora-generator-calendar *FloraGen*) month day)))
|
||||
(define (show-date d+s)
|
||||
`(p
|
||||
"The " ,(english:ordinal (date+sign-day d+s)) " of " ,(date+sign-month-name d+s) " "
|
||||
"is under the astrological sign of " ,(date+sign-sign-name d+s) ". " (br)
|
||||
(img ((src ,(string-append *FloraGenDataDir* "/" (date+sign-sign-symbol d+s)))
|
||||
(width "64")
|
||||
(height "64")
|
||||
))))
|
||||
`(article
|
||||
,(if req-flora
|
||||
`(section
|
||||
(h3 ,(string-append "YYYY-" (number->string month) "-" (number->string day)))
|
||||
,(show-date req-flora))
|
||||
"")
|
||||
(section
|
||||
(h3 "Convert a date to Floraverse date")
|
||||
(form ((action "/Calendar"))
|
||||
(label "Pick a date: "
|
||||
(input ((name "date")
|
||||
(type "date")
|
||||
(value ,(string-append
|
||||
(number->string (date-year today)) "-"
|
||||
(number->string (date-month today)) "-"
|
||||
(number->string (date-day today)))))))
|
||||
(br)
|
||||
(button "Convert to Floraverse date")))
|
||||
(section
|
||||
(h3 "Today")
|
||||
,(show-date today-flora))
|
||||
))))
|
||||
|
|
@ -0,0 +1,41 @@
|
|||
#lang racket/base
|
||||
|
||||
; Utility to build a sitemap and provide links in headers
|
||||
(require
|
||||
racket/string)
|
||||
|
||||
(provide
|
||||
sitemap
|
||||
build-headers)
|
||||
|
||||
(define *sitemap-list* '()) ; sitemap
|
||||
|
||||
; Site structure
|
||||
(struct sitepage
|
||||
(name ; Name displayed in headers, or #f if the page should not be shown in the header (but still considered when displaying the headers, mostly relevant for second-level pages)
|
||||
path ; Absolute path to the page
|
||||
link? ; Indicate if the link is clickable when on the same page
|
||||
))
|
||||
|
||||
; Function to set the sitemap
|
||||
(define (sitemap lst)
|
||||
(set! *sitemap-list*
|
||||
(map (lambda (x) (apply sitepage x)) lst)))
|
||||
|
||||
; Navigation link
|
||||
(define (navigation-link str-path page)
|
||||
(if (not (sitepage-name page))
|
||||
""
|
||||
`(section ((class "nav-item"))
|
||||
,(if (or (not (equal? str-path (sitepage-path page)))
|
||||
(sitepage-link? page))
|
||||
`(a ((href ,(sitepage-path page))) ,(sitepage-name page))
|
||||
(sitepage-name page)))))
|
||||
|
||||
; Build the navigation header
|
||||
(define (build-headers current-path)
|
||||
(let ((str-path (string-join current-path "/" #:before-first "/")))
|
||||
(map
|
||||
(lambda (x)
|
||||
(navigation-link str-path x))
|
||||
*sitemap-list*)))
|
||||
|
|
@ -0,0 +1,73 @@
|
|||
#lang racket/base
|
||||
|
||||
; Templates for the pages
|
||||
(require
|
||||
"../webcontainer/weblets.rkt"
|
||||
"../webcontainer/weblet-parameter.rkt"
|
||||
"sitemap.rkt"
|
||||
racket/date
|
||||
)
|
||||
|
||||
(provide
|
||||
make-nav-header
|
||||
pages:template
|
||||
pages:adaptable-template)
|
||||
|
||||
; Make the header
|
||||
(define (make-nav-header param)
|
||||
(define path (weblet-parameter-path param))
|
||||
`(header
|
||||
; Current page
|
||||
(nav ,@(build-headers path))))
|
||||
|
||||
; Main template for pages
|
||||
(define (pages:template
|
||||
#:title title ; Title
|
||||
#:content content ; Content, may be a function taking a weblet-parameter
|
||||
#:date [date #f] ; Date
|
||||
#:stylesheets [stylesheets (list)] ; Stylesheets to use on the page
|
||||
#:scripts [scripts (list)] ; Scripts to use of the page
|
||||
#:on-load [on-load #f] ; the onload attribute of the body of the page
|
||||
#:error-code [error-code 200] ; Error code returned
|
||||
)
|
||||
(html-page-weblet
|
||||
#:error-code error-code
|
||||
#:body
|
||||
(lambda (param)
|
||||
`(html
|
||||
(head
|
||||
(title ,title)
|
||||
(meta ((charset "UTF-8")))
|
||||
(link ((href "/css/beleth.css")(rel "stylesheet")(type "text/css")(media "all")))
|
||||
,@(map
|
||||
(lambda (x)
|
||||
`(link ((href ,x)(rel "stylesheet")(type "text/css")(media "all"))))
|
||||
stylesheets)
|
||||
,@(map
|
||||
(lambda (x)
|
||||
`(script ((src ,x)) " "))
|
||||
scripts)
|
||||
)
|
||||
(body (,@(if on-load `((onload ,on-load)) '()))
|
||||
,(make-nav-header param)
|
||||
(main
|
||||
(h1 ,title)
|
||||
(hr)
|
||||
,(apply-or-return content param))
|
||||
(footer ,(string-append "©2015-" (number->string (date-year (current-date))) " Feufochmar"))
|
||||
)))))
|
||||
|
||||
; Adaptable template
|
||||
; Similar to pages:template, but the argument is a function taking the weblet parameters and returning a hash containing the arguments for pages:template
|
||||
(define (pages:adaptable-template content)
|
||||
(lambda (param)
|
||||
(define result (content param))
|
||||
((pages:template
|
||||
#:title (hash-ref result 'title "Untitled page")
|
||||
#:content (hash-ref result 'content)
|
||||
#:date (hash-ref result 'date #f)
|
||||
#:stylesheets (hash-ref result 'stylesheets (list))
|
||||
#:scripts (hash-ref result 'scripts (list))
|
||||
#:on-load (hash-ref result 'on-load #f)
|
||||
#:error-code (hash-ref result 'error-code 200))
|
||||
param)))
|
||||
|
|
@ -0,0 +1,59 @@
|
|||
#lang racket/base
|
||||
(require racket/match)
|
||||
(provide http-message)
|
||||
|
||||
; Return the message corresponding to the given code
|
||||
(define (http-message code)
|
||||
(match code
|
||||
(200 #"OK")
|
||||
(404 #"Not found")
|
||||
(201 #"Created")
|
||||
(202 #"Accepted")
|
||||
(203 #"Non-Authoritative Information")
|
||||
(204 #"No Content")
|
||||
(205 #"Reset Content")
|
||||
(206 #"Partial Content")
|
||||
(226 #"IM Used")
|
||||
(300 #"Multiple Choices")
|
||||
(301 #"Moved Permanently")
|
||||
(302 #"Found")
|
||||
(303 #"See Other")
|
||||
(304 #"Not Modified")
|
||||
(305 #"Use Proxy")
|
||||
(307 #"Temporary Redirect")
|
||||
(308 #"Permanent Redirect")
|
||||
(310 #"Too many Redirects")
|
||||
(400 #"Bad Request")
|
||||
(401 #"Unauthorized")
|
||||
(402 #"Payment Required")
|
||||
(403 #"Forbidden")
|
||||
(405 #"Method Not Allowed")
|
||||
(406 #"Not Acceptable")
|
||||
(407 #"Proxy Authentication Required")
|
||||
(408 #"Request Time-out")
|
||||
(409 #"Conflict")
|
||||
(410 #"Gone")
|
||||
(411 #"Length Required")
|
||||
(412 #"Precondition Failed")
|
||||
(413 #"Request Entity Too Large")
|
||||
(414 #"Request-URI Too Long")
|
||||
(415 #"Unsupported Media Type")
|
||||
(416 #"Requested range unsatisfiable")
|
||||
(417 #"Expectation failed")
|
||||
(418 #"I'm a teapot")
|
||||
(421 #"Misdirected Request")
|
||||
(426 #"Upgrade Required")
|
||||
(428 #"Precondition Required")
|
||||
(429 #"Too Many Requests")
|
||||
(431 #"Request Header Fields Too Large")
|
||||
(451 #"Unavailable For Legal Reasons")
|
||||
(500 #"Internal Server Error")
|
||||
(501 #"Not Implemented")
|
||||
(502 #"Bad Gateway")
|
||||
(503 #"Service Unavailable")
|
||||
(504 #"Gateway Time-out")
|
||||
(505 #"HTTP Version not supported")
|
||||
(506 #"Variant Also Negotiates")
|
||||
(510 #"Not extended")
|
||||
(511 #"Network authentication")
|
||||
(_ #"Other")))
|
||||
|
|
@ -0,0 +1,319 @@
|
|||
#lang racket/base
|
||||
(require
|
||||
racket/string
|
||||
net/url
|
||||
web-server/web-server
|
||||
web-server/dispatchers/filesystem-map
|
||||
web-server/dispatchers/dispatch
|
||||
(prefix-in servlet: web-server/dispatchers/dispatch-servlets)
|
||||
(prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)
|
||||
(prefix-in files: web-server/dispatchers/dispatch-files)
|
||||
web-server/servlet/setup
|
||||
web-server/stuffers
|
||||
web-server/managers/none
|
||||
web-server/http/redirect
|
||||
web-server/http/request-structs
|
||||
web-server/private/mime-types
|
||||
"../collection/tree.rkt"
|
||||
"weblet-parameter.rkt"
|
||||
"website.rkt"
|
||||
)
|
||||
|
||||
(provide
|
||||
make-webcontainer
|
||||
webcontainer-start
|
||||
webcontainer-add-weblet! webcontainer-set-404-weblet!
|
||||
webcontainer-add-symlink! webcontainer-add-redirection!
|
||||
webcontainer-add-matching-weblet!
|
||||
webcontainer-add-website!)
|
||||
|
||||
; webcontainer - a webserver to run weblets
|
||||
; A weblet is a procedure taking a weblet-parameter and returning a response
|
||||
(struct webcontainer
|
||||
(server-port ; Port to listen
|
||||
server-address ; Address to listen
|
||||
static ; Path to non-dynamic assets
|
||||
weblets ; weblets - dynamic pages
|
||||
symlinks ; symlinks for path linking to another weblet
|
||||
redirections ; redirections for path going to another website
|
||||
matching-weblets ; like weblets, but extract parameters from the url
|
||||
dispatcher ; servlet dispatcher
|
||||
not-found-dispatcher ; Dispatcher for not found elements
|
||||
))
|
||||
|
||||
; Helper: Make a servlet
|
||||
(define (make-servlet function)
|
||||
(make-stateless.servlet
|
||||
"."
|
||||
default-stuffer
|
||||
(create-none-manager #f)
|
||||
function))
|
||||
|
||||
; Helper: convert to a string list path, remove the empty elements in the path
|
||||
(define (url->path url)
|
||||
(filter
|
||||
non-empty-string?
|
||||
(map
|
||||
path/param-path
|
||||
(url-path url))))
|
||||
|
||||
; Helper: check if the path match an element in the tree
|
||||
(define (has-matching? tr path)
|
||||
(not (not (get-matching tr path))))
|
||||
|
||||
; Helper: produce a pair of weblet and hash table of params
|
||||
(define (make-weblet-params weblet params)
|
||||
(let ((hparams (make-hash)))
|
||||
(if weblet
|
||||
(begin
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(hash-set! hparams (car x) (cdr x)))
|
||||
params)
|
||||
(cons weblet hparams))
|
||||
#f)))
|
||||
|
||||
; Helper: get the weblet and extracted parameters if the path match an element in the tree
|
||||
(define (get-matching tr path [params (list)])
|
||||
(cond
|
||||
((and (eq? #f (tree-key tr)) (null? path))
|
||||
; ROOT of the tree, and itself asked for
|
||||
(if (tree-value tr)
|
||||
(cons (tree-value tr) (make-hash))
|
||||
#f))
|
||||
((null? path)
|
||||
; Should not happen outside the ROOT => not found...
|
||||
#f)
|
||||
((eq? #f (tree-key tr))
|
||||
; ROOT of the tree, but not itself asked => pass to children with the same path
|
||||
(let ((ret
|
||||
(filter
|
||||
(lambda (x) x)
|
||||
(map
|
||||
(lambda (x)
|
||||
(get-matching x path params))
|
||||
(tree-children tr)))))
|
||||
(if (null? ret)
|
||||
#f
|
||||
(car ret))))
|
||||
((and (symbol? (tree-key tr)) (null? (cdr path)))
|
||||
; match pattern, node found
|
||||
(make-weblet-params
|
||||
(tree-value tr)
|
||||
(cons (cons (tree-key tr) (car path))
|
||||
params)))
|
||||
((symbol? (tree-key tr))
|
||||
; match pattern + check children
|
||||
(let* ((p (cons (cons (tree-key tr) (car path)) params))
|
||||
(ret
|
||||
(filter
|
||||
(lambda (x) x)
|
||||
(map
|
||||
(lambda (x)
|
||||
(get-matching x (cdr path) p))
|
||||
(tree-children tr)))))
|
||||
(if (null? ret)
|
||||
#f
|
||||
(car ret))))
|
||||
((and (equal? (tree-key tr) (car path)) (null? (cdr path)))
|
||||
; Node found
|
||||
(make-weblet-params (tree-value tr) params))
|
||||
((equal? (tree-key tr) (car path))
|
||||
; Check children
|
||||
(let ((ret
|
||||
(filter
|
||||
(lambda (x) x)
|
||||
(map
|
||||
(lambda (x)
|
||||
(get-matching x (cdr path) params))
|
||||
(tree-children tr)))))
|
||||
(if (null? ret)
|
||||
#f
|
||||
(car ret))))
|
||||
(#t #f)
|
||||
))
|
||||
|
||||
; Webcontainer constructor
|
||||
(define (make-webcontainer
|
||||
#:port [port 8080]
|
||||
#:address [address #f]
|
||||
#:static [static (make-immutable-hash '(("" . "./static")))]
|
||||
)
|
||||
(let* ((weblets (make-hash))
|
||||
(symlinks (make-hash))
|
||||
(redirections (make-hash))
|
||||
(matching-weblets (make-tree))
|
||||
; Servlet for weblets
|
||||
(weblet-servlet
|
||||
(make-servlet
|
||||
(lambda (req)
|
||||
(let* ((path (url->path (request-uri req)))
|
||||
(weblet (hash-ref weblets path)))
|
||||
(weblet (make-weblet-parameter #:request req #:path path))))))
|
||||
; Servlet for symlinks
|
||||
(symlink-servlet
|
||||
(make-servlet
|
||||
(lambda (req)
|
||||
(let* ((path (url->path (request-uri req)))
|
||||
(real-path (hash-ref symlinks path))
|
||||
(weblet (hash-ref weblets real-path)))
|
||||
(weblet (make-weblet-parameter #:request req #:path real-path))))))
|
||||
; Servlet for redirections
|
||||
(redirection-servlet
|
||||
(make-servlet
|
||||
(lambda (req)
|
||||
(let* ((path (url->path (request-uri req)))
|
||||
(to (hash-ref redirections path)))
|
||||
(redirect-to to permanently)))))
|
||||
; Servlet for using matching servlets
|
||||
(matching-servlet
|
||||
(make-servlet
|
||||
(lambda (req)
|
||||
(let* ((path (url->path (request-uri req)))
|
||||
(weblet-params (get-matching matching-weblets path)))
|
||||
((car weblet-params) (make-weblet-parameter #:request req #:path path #:match (cdr weblet-params)))))))
|
||||
; Not found servlet
|
||||
(not-found-servlet
|
||||
(make-servlet
|
||||
(lambda (req)
|
||||
(let* ((path (url->path (request-uri req)))
|
||||
(weblet (hash-ref weblets 404)))
|
||||
(weblet (make-weblet-parameter #:request req #:path path))))))
|
||||
)
|
||||
(webcontainer
|
||||
port
|
||||
address
|
||||
static
|
||||
weblets
|
||||
symlinks
|
||||
redirections
|
||||
matching-weblets
|
||||
; dispatcher
|
||||
(lambda (url)
|
||||
(let ((path (url->path url)))
|
||||
(cond
|
||||
((hash-has-key? redirections path) redirection-servlet)
|
||||
((hash-has-key? symlinks path) symlink-servlet)
|
||||
((hash-has-key? weblets path) weblet-servlet)
|
||||
((has-matching? matching-weblets path) matching-servlet)
|
||||
(#t (next-dispatcher)))))
|
||||
; not-found-dispatcher
|
||||
(lambda (url)
|
||||
not-found-servlet)
|
||||
)))
|
||||
|
||||
(define (remove-prefix path pfx)
|
||||
(cond
|
||||
((null? pfx) path)
|
||||
((null? path) path)
|
||||
((equal? (car path) (car pfx))
|
||||
(remove-prefix (cdr path) (cdr pfx)))
|
||||
(#t path)))
|
||||
|
||||
; Start the server - do not return
|
||||
(define (webcontainer-start wcontainer)
|
||||
(serve
|
||||
#:dispatch
|
||||
(apply
|
||||
sequencer:make
|
||||
(append
|
||||
; File dispatchers for each entry in the static map
|
||||
(hash-map
|
||||
(webcontainer-static wcontainer)
|
||||
(lambda (root dir)
|
||||
(define root-path (clean-path root))
|
||||
(define dir-path (string->path dir))
|
||||
(files:make
|
||||
#:url->path (lambda (url)
|
||||
; Remove the root from the url
|
||||
(define path-without-root
|
||||
(remove-prefix
|
||||
(url->path url)
|
||||
root-path))
|
||||
; Build the new url
|
||||
(define url-without-root
|
||||
(path->url
|
||||
(string->path
|
||||
(string-join path-without-root "/" #:before-first "/"))))
|
||||
;
|
||||
((make-url->path dir-path) url-without-root))
|
||||
#:path->mime-type (make-path->mime-type "./mime.types"))))
|
||||
(list
|
||||
; Servlet dispatcher
|
||||
(servlet:make (webcontainer-dispatcher wcontainer))
|
||||
; 404 error servlet
|
||||
(servlet:make (webcontainer-not-found-dispatcher wcontainer))
|
||||
)))
|
||||
#:port (webcontainer-server-port wcontainer)
|
||||
#:listen-ip (webcontainer-server-address wcontainer))
|
||||
(do-not-return))
|
||||
|
||||
; Helper when defining a path to remove the unnecessary "/"
|
||||
(define (clean-path str)
|
||||
(filter
|
||||
non-empty-string?
|
||||
(string-split str "/")))
|
||||
|
||||
; Add a weblet to the container
|
||||
(define (webcontainer-add-weblet! wcontainer path weblet)
|
||||
(hash-set!
|
||||
(webcontainer-weblets wcontainer)
|
||||
(clean-path path)
|
||||
weblet))
|
||||
|
||||
; Set the 404 error page weblet
|
||||
(define (webcontainer-set-404-weblet! wcontainer weblet)
|
||||
(hash-set!
|
||||
(webcontainer-weblets wcontainer)
|
||||
404
|
||||
weblet))
|
||||
|
||||
; Add an internal redirection: the link given refer to another weblet
|
||||
(define (webcontainer-add-symlink! wcontainer from to)
|
||||
(hash-set!
|
||||
(webcontainer-symlinks wcontainer)
|
||||
(clean-path from)
|
||||
(clean-path to)))
|
||||
|
||||
; Add an external redirection: the link given goes to another website
|
||||
(define (webcontainer-add-redirection! wcontainer from to)
|
||||
(hash-set!
|
||||
(webcontainer-redirections wcontainer)
|
||||
(clean-path from)
|
||||
to))
|
||||
|
||||
; Matching weblet: the path contain parameters to extract when matching
|
||||
(define (webcontainer-add-matching-weblet! wcontainer path weblet)
|
||||
(tree-set!
|
||||
(webcontainer-matching-weblets wcontainer)
|
||||
(map
|
||||
(lambda (x)
|
||||
(if (and (string-prefix? x "{")
|
||||
(string-suffix? x "}"))
|
||||
(string->symbol
|
||||
(substring x 1 (- (string-length x) 1)))
|
||||
x))
|
||||
(clean-path path))
|
||||
weblet))
|
||||
|
||||
; Add a full website to the webcontainer
|
||||
(define (webcontainer-add-website! wcontainer wsite [parent-path ""])
|
||||
(define node (tree-value wsite))
|
||||
(define path (string-append parent-path "/" (website-node-url node)))
|
||||
(define type (website-node-type node))
|
||||
(define weblet (website-node-weblet node))
|
||||
(case type
|
||||
((weblet)
|
||||
(webcontainer-add-weblet! wcontainer path weblet))
|
||||
((symlink)
|
||||
(webcontainer-add-symlink! wcontainer path weblet))
|
||||
((redirection)
|
||||
(webcontainer-add-redirection! wcontainer path weblet))
|
||||
((matching-weblet)
|
||||
(webcontainer-add-matching-weblet! wcontainer path weblet))
|
||||
(else
|
||||
(error "Unexpected type: " type)))
|
||||
(for-each
|
||||
(lambda (child)
|
||||
(webcontainer-add-website! wcontainer child path))
|
||||
(tree-children wsite)))
|
||||
|
|
@ -0,0 +1,101 @@
|
|||
#lang racket/base
|
||||
|
||||
(require
|
||||
web-server/http
|
||||
web-server/http/cookie-parse
|
||||
net/url-structs
|
||||
racket/string)
|
||||
|
||||
(provide
|
||||
make-weblet-parameter
|
||||
weblet-parameter-ref
|
||||
weblet-parameter-cookie-ref
|
||||
weblet-parameter-file-port-ref
|
||||
weblet-parameter-method
|
||||
weblet-parameter-protocol
|
||||
weblet-parameter-host
|
||||
; Fields of struct
|
||||
weblet-parameter-request
|
||||
weblet-parameter-path
|
||||
weblet-parameter-match)
|
||||
|
||||
; weblet-parameter
|
||||
; Contains: the request, the path of the request and a hash of matching parameters in the path
|
||||
(struct weblet-parameter
|
||||
(request ; HTTP request
|
||||
path ; path called for the request, as a list of strings
|
||||
match ; hash used in paramters
|
||||
))
|
||||
|
||||
; Constructor
|
||||
(define (make-weblet-parameter
|
||||
#:request request
|
||||
#:path path
|
||||
#:match [match (make-hash)]
|
||||
#:cookies [cookies (make-hash)])
|
||||
(weblet-parameter
|
||||
request
|
||||
path
|
||||
match))
|
||||
|
||||
; Get a value from the request or the match parameters
|
||||
; key is a symbol
|
||||
(define (weblet-parameter-ref wp key (default #f))
|
||||
(let* ((query (request-bindings/raw (weblet-parameter-request wp)))
|
||||
(req (bindings-assq (string->bytes/utf-8 (symbol->string key)) query))
|
||||
(mat (hash-ref (weblet-parameter-match wp) key default)))
|
||||
; Priority: from request, from match
|
||||
(or (and req (bytes->string/utf-8
|
||||
(or (and (binding:file/port? req) (binding:file-filename req))
|
||||
(binding:form-value req))))
|
||||
mat)))
|
||||
|
||||
; Get a cookie from the request. Return the cookie value as a string or #f if the asked value was not passed.
|
||||
; Key is a string
|
||||
(define (weblet-parameter-cookie-ref wp key (default #f))
|
||||
(define cookie
|
||||
(findf
|
||||
(lambda (c) (equal? key (client-cookie-name c)))
|
||||
(request-cookies (weblet-parameter-request wp))))
|
||||
(and cookie (client-cookie-value cookie)))
|
||||
|
||||
; Get the file port from the request. Return the port or #f if the asked file was not passed.
|
||||
; Key is a symbol
|
||||
(define (weblet-parameter-file-port-ref wp key)
|
||||
(define query (request-bindings/raw (weblet-parameter-request wp)))
|
||||
(define req (bindings-assq (string->bytes/utf-8 (symbol->string key)) query))
|
||||
(and req (binding:file/port? req)
|
||||
(binding:file/port-in req)))
|
||||
|
||||
; Get the method used for the request.
|
||||
; Method is returned as a symbol
|
||||
(define (weblet-parameter-method wp)
|
||||
(define method (request-method (weblet-parameter-request wp)))
|
||||
(case method
|
||||
((#"GET") 'get)
|
||||
((#"HEAD") 'head)
|
||||
((#"POST") 'post)
|
||||
((#"PUT") 'put)
|
||||
((#"DELETE") 'delete)
|
||||
((#"TRACE") 'trace)
|
||||
((#"OPTIONS") 'options)
|
||||
((#"CONNECT") 'connect)
|
||||
((#"PATCH") 'patch)
|
||||
(else 'other-method)))
|
||||
|
||||
; Get the protocol used for the request, as a symbol
|
||||
(define (weblet-parameter-protocol wp)
|
||||
; Check the header: X-Scheme
|
||||
; As the application is expected to be behind a proxy, the proxy must set the X-Scheme header to indicate which protocol was used.
|
||||
(define scheme (headers-assq #"X-Scheme" (request-headers/raw (weblet-parameter-request wp))))
|
||||
(and scheme (string->symbol (bytes->string/utf-8 (header-value scheme)))))
|
||||
|
||||
; Get the host used for the request
|
||||
(define (weblet-parameter-host wp)
|
||||
; Header: Host (as string)
|
||||
; As the application is expected to be behind a proxy, the proxy must set the Host header to indicate which address was asked
|
||||
(define host-header (headers-assq #"Host" (request-headers/raw (weblet-parameter-request wp))))
|
||||
(define host (or (and host-header (bytes->string/utf-8 (header-value host-header)))
|
||||
"localhost"))
|
||||
; Remove the port part
|
||||
(car (string-split host ":")))
|
||||
|
|
@ -0,0 +1,73 @@
|
|||
#lang racket/base
|
||||
; Helpers to simplify the writing of weblets
|
||||
|
||||
(require
|
||||
web-server/http
|
||||
web-server/http/redirect
|
||||
net/url-string
|
||||
xml
|
||||
"http-message.rkt"
|
||||
"weblet-parameter.rkt")
|
||||
|
||||
(provide
|
||||
apply-or-return
|
||||
raw-data-weblet
|
||||
html-page-weblet
|
||||
redirect-to-https-weblet)
|
||||
|
||||
; Apply or return - If value is a procedure, apply it to the request, or else return value
|
||||
(define (apply-or-return value param)
|
||||
(if (procedure? value)
|
||||
(value param)
|
||||
value))
|
||||
|
||||
; Weblet to return raw data
|
||||
(define (raw-data-weblet
|
||||
#:body body ; body, as a bytes-string or a procedure taking the request and returning a bytes-string
|
||||
#:content-type [content-type #"text/plain;charset=utf-8"] ; type of the content, as a bytes-string
|
||||
#:error-code [error-code 200] ; page error code
|
||||
#:headers [headers (list)] ; headers of the response, or a procedure taking the request and returning the list of headers
|
||||
)
|
||||
(lambda (param)
|
||||
(response/full
|
||||
error-code (http-message error-code)
|
||||
(current-seconds)
|
||||
content-type
|
||||
(apply-or-return headers param)
|
||||
(list
|
||||
(apply-or-return body param)))))
|
||||
|
||||
; Weblet to return html data
|
||||
(define (html-page-weblet
|
||||
#:body body ; body, as an xexpr or a procedure taking the request and returning an xexpr
|
||||
#:error-code [error-code 200] ; page error code
|
||||
#:headers [headers (list)] ; headers of the response, or a procedure taking the request and returning the list of headers
|
||||
)
|
||||
(lambda (param)
|
||||
(response/full
|
||||
error-code (http-message error-code)
|
||||
(current-seconds)
|
||||
TEXT/HTML-MIME-TYPE
|
||||
(apply-or-return headers param)
|
||||
(list
|
||||
(string->bytes/utf-8
|
||||
(xexpr->string
|
||||
(apply-or-return body param)))))))
|
||||
|
||||
; Weblet to redirect to https, same place, same method
|
||||
(define redirect-to-https-weblet
|
||||
(lambda (param)
|
||||
(define uri (request-uri (weblet-parameter-request param)))
|
||||
(define new-uri
|
||||
(make-url
|
||||
"https"
|
||||
(url-user uri)
|
||||
(url-host uri)
|
||||
(url-port uri)
|
||||
(url-path-absolute? uri)
|
||||
(url-path uri)
|
||||
(url-query uri)
|
||||
(url-fragment uri)))
|
||||
(redirect-to
|
||||
(url->string new-uri)
|
||||
temporarily/same-method)))
|
||||
|
|
@ -0,0 +1,32 @@
|
|||
#lang racket/base
|
||||
|
||||
; An helper to fill a webcontainer with weblets
|
||||
(require
|
||||
"../collection/tree.rkt")
|
||||
|
||||
(provide
|
||||
website
|
||||
website-node-url
|
||||
website-node-type
|
||||
website-node-weblet)
|
||||
|
||||
; Values in the website tree
|
||||
(struct website-node
|
||||
(url ; the partial url of the link, relative to parent
|
||||
type ; the type of weblet
|
||||
weblet ; the weblet associated (or a link for symlinks and redirections)
|
||||
))
|
||||
|
||||
; website syntax to build the structure
|
||||
(define-syntax website
|
||||
(syntax-rules ()
|
||||
( (website path type weblet (childparam ...) ...)
|
||||
(tree
|
||||
(if (equal? path "") #f path)
|
||||
(website-node
|
||||
path
|
||||
(quote type)
|
||||
weblet)
|
||||
(list
|
||||
(website childparam ...)
|
||||
...)))))
|
||||
Loading…
Reference in New Issue