extra/hipku/hipku.factor

   1 ! Copyright (C) 2023 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: arrays ascii combinators endian grouping ip-parser kernel
   5 literals math sequences splitting ;
   6
   7 IN: hipku
   8
   9 <PRIVATE
  10
  11 CONSTANT: animal-adjectives {
  12     "agile" "bashful" "clever" "clumsy" "drowsy" "fearful"
  13     "graceful" "hungry" "lonely" "morose" "placid" "ruthless"
  14     "silent" "thoughtful" "vapid" "weary"
  15 }
  16
  17 CONSTANT: animal-colors {
  18     "beige" "black" "blue" "bright" "bronze" "brown" "dark"
  19     "drab" "green" "gold" "grey" "jade" "pale" "pink" "red"
  20     "white"
  21 }
  22
  23 CONSTANT: animal-nouns {
  24     "ape" "bear" "crow" "dove" "frog" "goat" "hawk" "lamb"
  25     "mouse" "newt" "owl" "pig" "rat" "snake" "toad" "wolf"
  26 }
  27
  28 CONSTANT: animal-verbs {
  29     "aches" "basks" "cries" "dives" "eats" "fights" "groans"
  30     "hunts" "jumps" "lies" "prowls" "runs" "sleeps" "thrives"
  31     "wakes" "yawns"
  32 }
  33
  34 CONSTANT: nature-adjectives {
  35     "ancient" "barren" "blazing" "crowded" "distant" "empty"
  36     "foggy" "fragrant" "frozen" "moonlit" "peaceful" "quiet"
  37     "rugged" "serene" "sunlit" "wind-swept"
  38 }
  39
  40 CONSTANT: nature-nouns {
  41     "canyon" "clearing" "desert" "foothills" "forest"
  42     "grasslands" "jungle" "meadow" "mountains" "prairie" "river"
  43     "rockpool" "sand-dune" "tundra" "valley" "wetlands"
  44 }
  45
  46 CONSTANT: plant-nouns {
  47     "autumn colors"
  48     "cherry blossoms"
  49     "chrysanthemums"
  50     "crabapple blooms"
  51     "dry palm fronds"
  52     "fat horse chestnuts"
  53     "forget-me-nots"
  54     "jasmine petals"
  55     "lotus flowers"
  56     "ripe blackberries"
  57     "the maple seeds"
  58     "the pine needles"
  59     "tiger lillies"
  60     "water lillies"
  61     "willow branches"
  62     "yellowwood leaves"
  63 }
  64
  65 CONSTANT: plant-verbs {
  66     "blow" "crunch" "dance" "drift" "drop" "fall" "grow" "pile"
  67     "rest" "roll" "show" "spin" "stir" "sway" "turn" "twist"
  68 }
  69
  70 CONSTANT: adjectives {
  71     "ace" "apt" "arched" "ash" "bad" "bare" "beige" "big"
  72     "black" "bland" "bleak" "blond" "blue" "blunt" "blush" "bold"
  73     "bone" "both" "bound" "brash" "brass" "brave" "brief" "brisk"
  74     "broad" "bronze" "brushed" "burned" "calm" "ceil" "chaste"
  75     "cheap" "chilled" "clean" "coarse" "cold" "cool" "corn" "crass"
  76     "crazed" "cream" "crisp" "crude" "cruel" "cursed" "cute" "daft"
  77     "damp" "dark" "dead" "deaf" "dear" "deep" "dense" "dim" "drab"
  78     "dry" "dull" "faint" "fair" "fake" "false" "famed" "far" "fast"
  79     "fat" "fierce" "fine" "firm" "flat" "flawed" "fond" "foul"
  80     "frail" "free" "fresh" "full" "fun" "glum" "good" "grave" "gray"
  81     "great" "green" "grey" "grim" "gruff" "hard" "harsh" "high"
  82     "hoarse" "hot" "huge" "hurt" "ill" "jade" "jet" "jinxed" "keen"
  83     "kind" "lame" "lank" "large" "last" "late" "lean" "lewd" "light"
  84     "limp" "live" "loath" "lone" "long" "loose" "lost" "louche"
  85     "loud" "low" "lush" "mad" "male" "masked" "mean" "meek" "mild"
  86     "mint" "moist" "mute" "near" "neat" "new" "nice" "nude" "numb"
  87     "odd" "old" "pained" "pale" "peach" "pear" "peeved" "pink"
  88     "piqued" "plain" "plum" "plump" "plush" "poor" "posed" "posh"
  89     "prim" "prime" "prompt" "prone" "proud" "prune" "puce" "pure"
  90     "quaint" "quartz" "quick" "rare" "raw" "real" "red" "rich"
  91     "ripe" "rough" "rude" "rushed" "rust" "sad" "safe" "sage" "sane"
  92     "scortched" "shaped" "sharp" "sheared" "short" "shrewd" "shrill"
  93     "shrunk" "shy" "sick" "skilled" "slain" "slick" "slight" "slim"
  94     "slow" "small" "smart" "smooth" "smug" "snide" "snug" "soft"
  95     "sore" "sought" "sour" "spare" "sparse" "spent" "spoilt" "spry"
  96     "squat" "staid" "stale" "stary" "staunch" "steep" "stiff"
  97     "strange" "straw" "stretched" "strict" "striped" "strong"
  98     "suave" "sure" "svelte" "swank" "sweet" "swift" "tall" "tame"
  99     "tan" "tart" "taut" "teal" "terse" "thick" "thin" "tight" "tiny"
 100     "tired" "toothed" "torn" "tough" "trim" "trussed" "twin" "used"
 101     "vague" "vain" "vast" "veiled" "vexed" "vile" "warm" "weak"
 102     "webbed" "wrong" "wry" "young"
 103 }
 104
 105 CONSTANT: nouns {
 106     "ants" "apes" "asps" "balls" "barb" "barbs" "bass" "bats"
 107     "beads" "beaks" "bears" "bees" "bells" "belts" "birds" "blades"
 108     "blobs" "blooms" "boars" "boats" "bolts" "books" "bowls" "boys"
 109     "bream" "brides" "broods" "brooms" "brutes" "bucks" "bulbs"
 110     "bulls" "busks" "cakes" "calfs" "calves" "cats" "char" "chests"
 111     "choirs" "clams" "clans" "clouds" "clowns" "cod" "coins" "colts"
 112     "cones" "cords" "cows" "crabs" "cranes" "crows" "cults" "czars"
 113     "darts" "dates" "deer" "dholes" "dice" "discs" "does" "dogs"
 114     "doors" "dopes" "doves" "dreams" "drones" "ducks" "dunes"
 115     "dwarves" "eels" "eggs" "elk" "elks" "elms" "elves" "ewes"
 116     "eyes" "faces" "facts" "fawns" "feet" "ferns" "fish" "fists"
 117     "flames" "fleas" "flocks" "flutes" "foals" "foes" "fools" "fowl"
 118     "frogs" "fruits" "gangs" "gar" "geese" "gems" "germs" "ghosts"
 119     "gnomes" "goats" "grapes" "grooms" "grouse" "grubs" "guards"
 120     "gulls" "hands" "hares" "hawks" "heads" "hearts" "hens" "herbs"
 121     "hills" "hogs" "holes" "hordes" "ide" "jars" "jays" "kids"
 122     "kings" "kites" "lads" "lakes" "lambs" "larks" "lice" "lights"
 123     "limbs" "looms" "loons" "mares" "masks" "mice" "mimes" "minks"
 124     "mists" "mites" "mobs" "molds" "moles" "moons" "moths" "newts"
 125     "nymphs" "orbs" "orcs" "owls" "pearls" "pears" "peas" "perch"
 126     "pigs" "pikes" "pines" "plains" "plants" "plums" "pools"
 127     "prawns" "prunes" "pugs" "punks" "quail" "quails" "queens"
 128     "quills" "rafts" "rains" "rams" "rats" "rays" "ribs" "rocks"
 129     "rooks" "ruffs" "runes" "sands" "seals" "seas" "seeds" "serfs"
 130     "shards" "sharks" "sheep" "shells" "ships" "shoals" "shrews"
 131     "shrimp" "skate" "skies" "skunks" "sloths" "slugs" "smew"
 132     "smiles" "snails" "snakes" "snipes" "sole" "songs" "spades"
 133     "sprats" "sprouts" "squabs" "squads" "squares" "squid" "stars"
 134     "stoats" "stones" "storks" "strays" "suns" "swans" "swarms"
 135     "swells" "swifts" "tars" "teams" "teeth" "terns" "thorns"
 136     "threads" "thrones" "ticks" "toads" "tools" "trees" "tribes"
 137     "trolls" "trout" "tunes" "tusks" "veins" "verbs" "vines" "voles"
 138     "wasps" "waves" "wells" "whales" "whelks" "whiffs" "winds"
 139     "wolves" "worms" "wraiths" "wrens" "yaks"
 140 }
 141
 142 CONSTANT: verbs {
 143     "aid" "arm" "awe" "axe" "bag" "bait" "bare" "bash" "bathe"
 144     "beat" "bid" "bilk" "blame" "bleach" "bleed" "bless" "bluff"
 145     "blur" "boast" "boost" "boot" "bore" "botch" "breed" "brew"
 146     "bribe" "brief" "brine" "broil" "browse" "bruise" "build" "burn"
 147     "burst" "call" "calm" "carve" "chafe" "chant" "charge" "chart"
 148     "cheat" "check" "cheer" "chill" "choke" "chomp" "choose" "churn"
 149     "cite" "clamp" "clap" "clasp" "claw" "clean" "cleanse" "clip"
 150     "cloack" "clone" "clutch" "coax" "crack" "crave" "crunch" "cry"
 151     "cull" "cure" "curse" "cuss" "dare" "daze" "dent" "dig" "ding"
 152     "doubt" "dowse" "drag" "drain" "drape" "draw" "dread" "dredge"
 153     "drill" "drink" "drip" "drive" "drop" "drown" "dry" "dump" "eat"
 154     "etch" "face" "fail" "fault" "fear" "feed" "feel" "fetch"
 155     "fight" "find" "fix" "flap" "flay" "flee" "fling" "flip" "float"
 156     "foil" "forge" "free" "freeze" "frisk" "gain" "glimpse" "gnaw"
 157     "goad" "gouge" "grab" "grasp" "graze" "grieve" "grip" "groom"
 158     "guard" "guards" "guide" "gulp" "gush" "halt" "harm" "hate"
 159     "haul" "haunt" "have" "heal" "hear" "help" "herd" "hex" "hire"
 160     "hit" "hoist" "hound" "hug" "hurl" "irk" "jab" "jeer" "join"
 161     "jolt" "keep" "kick" "kill" "kiss" "lash" "leash" "leave" "lift"
 162     "like" "love" "lugg" "lure" "maim" "make" "mask" "meet" "melt"
 163     "mend" "miss" "mould" "move" "nab" "name" "need" "oust" "paint"
 164     "paw" "pay" "peck" "peeve" "pelt" "please" "pluck" "poach"
 165     "poll" "praise" "prick" "print" "probe" "prod" "prompt" "punch"
 166     "quash" "quell" "quote" "raid" "raise" "raze" "ride" "roast"
 167     "rouse" "rule" "scald" "scalp" "scar" "scathe" "score" "scorn"
 168     "scour" "scuff" "sear" "see" "seek" "seize" "send" "sense"
 169     "serve" "shake" "shear" "shift" "shoot" "shun" "slap" "slay"
 170     "slice" "smack" "smash" "smell" "smite" "snare" "snatch" "sniff"
 171     "snub" "soak" "spare" "splash" "split" "spook" "spray" "squash"
 172     "squeeze" "stab" "stain" "starve" "steal" "steer" "sting"
 173     "strike" "stun" "tag" "tame" "taste" "taunt" "teach" "tend"
 174 }
 175
 176 SYMBOLS: Octet octet octet. ;
 177
 178 CONSTANT: ipv4-key ${
 179     animal-adjectives animal-colors animal-nouns animal-verbs
 180     nature-adjectives nature-nouns plant-nouns plant-verbs
 181 }
 182
 183 CONSTANT: ipv4-schema ${
 184     "The" octet octet octet f
 185     octet "in the" octet octet. f
 186     Octet octet.
 187 }
 188
 189 CONSTANT: ipv6-key ${
 190     adjectives nouns adjectives nouns verbs adjectives
 191     adjectives adjectives adjectives adjectives nouns
 192     adjectives nouns verbs adjectives nouns
 193 }
 194
 195 CONSTANT: ipv6-schema ${
 196     Octet octet "and" octet octet f
 197     octet octet octet octet octet octet octet. f
 198     Octet octet octet octet octet.
 199 }
 200
 201 : split-octets ( byte-array -- octets )
 202     [ 16 /mod 2array ] { } map-as concat ;
 203
 204 : join-octets ( octets -- byte-array )
 205     2 <groups> [ first2 [ 16 * ] [ + ] bi* ] map ;
 206
 207 : split-bytes ( short-array -- byte-array )
 208     [ 256 /mod 2array ] { } map-as concat ;
 209
 210 : encode-key ( octets key -- key' )
 211     [ nth ] V{ } 2map-as reverse ;
 212
 213 : encode-hipku ( key schema -- hipku )
 214     [
 215         {
 216             { Octet [ dup pop unclip ch>upper prefix ] }
 217             { octet [ dup pop ] }
 218             { octet. [ dup pop "." append ] }
 219             [ ]
 220         } case
 221     ] map nip
 222     { f } split [ " " join ] map "\n" join ;
 223
 224 : clean-hipku ( hipku extra -- words )
 225     [ >lower " .\n" split harvest ]
 226     [ '[ _ member? ] reject " " join ] bi* ;
 227
 228 : decode-key ( hipku key -- seq )
 229     [ [ ?head ] find drop [ [ CHAR: \s = ] trim-head ] dip ] map nip ;
 230
 231 : decode-hipku ( hipku extra key -- seq )
 232     [ clean-hipku ] [ decode-key ] bi* ;
 233
 234 : ipv4>hipku ( ipv4 -- hipku )
 235     parse-ipv4 split-octets
 236     ipv4-key encode-key
 237     ipv4-schema encode-hipku ;
 238
 239 : hipku>ipv4 ( hipku -- ipv4 )
 240     { "in" "the" } ipv4-key decode-hipku join-octets be> ipv4-ntoa ;
 241
 242 : ipv6>hipku ( ipv6 -- hipku )
 243     parse-ipv6 split-bytes
 244     ipv6-key encode-key
 245     ipv6-schema encode-hipku ;
 246
 247 : hipku>ipv6 ( hipku -- ipv6 )
 248     { "and" } ipv6-key decode-hipku be> ipv6-ntoa ;
 249
 250 PRIVATE>
 251
 252 : hipku> ( hipku -- ipv4/ipv6 )
 253     " and " over subseq? [ hipku>ipv6 ] [ hipku>ipv4 ] if ;
 254
 255 : >hipku ( ipv4/ipv6 -- hipku )
 256     CHAR: : over index [ ipv6>hipku ] [ ipv4>hipku ] if ;