// mazes.4th // // version 1.0 - 2017-10-15 // // =================================================================== // // A Forth like interface on a turtle graphics engine, used to drw mazes. // // NOTE: // // data types can be almost anything, strings, ints floats for instance. // This also means Create Does> works a little different from Forth. // // =================================================================== // // © COPYRIGHT 2017 Blue Hell / Jan Punter // // This program is free software; you can redistribute it and/or modify // it under the terms of the GNU General Public License version 2 as // published by the Free Software Foundation; // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // You should have received a copy of the GNU General Public License // along with this program; if not, write to the Free Software // Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA // // For all listed email addresses : // // _dot. to be substituted by a dot '.' // 2@t2 to be substituted by an at sign '@' // // // Blue Hell is a trade mark owned by // // Jan Punter // Oogstplein 6 // 7545 HP Enschede // the Netherlands // http://www.iaf.nl/Users/BlueHell/ // http://bluehell.electro-music.com/ // j_dot.punter2@t2iaf_dot.nl // // All rights attributed to Blue Hell are owned by Jan Punter. // // // =================================================================== unload mazes.4th // forget about possible previous incarnation Decimal // work in decimal mode // opcodes for turtle graphics primitives, these must match the definitions in TMazeForth in the Pascal source 0 constant opClear // clear the graph 1 constant opRotateDegrees // rotate turtle direction over an angle specified in degrees 2 constant opRotateRadians // rotate turtle direction over an angle specified in radians 3 constant opForward // move the turtle into the current direction with the pen down 4 constant opMove // move the turtle into the current direction with the pen up 5 constant opPenUp // lift the pen 6 constant opPenDown // down the pen 7 constant opColor // set pen color 8 constant opInflate // inflate the graph 9 constant opPushState // push the turtle state onto the turtle stte stack 10 constant opPopState // pop the turtle state from the turtle state stack 11 constant opDupState // duplicate the top turtle stack entry 12 constant opDropState // remove the top turtle stack entry, not changing the turtle state 13 constant opSwapState // swap the top two turtle stack entries 14 constant opPen // Set the pen width 15 constant opDot // Set the vertex dot size to be used, zero means off 16 constant opLClear // Clear the LSystem interpreter 17 constant opLRule // Add a rule to the LSystem interpreter 18 constant opLMeaning // Add a meaning to the LSystem interpreter 19 constant opLSystem // Define a name, an axiom and a depth for the LSystem interpreter, it will build some forth code then 20 constant opExtent // Get the bounding box for the current graph // =================================================================== // Color codes, $ for hex numbers $fff8f0 constant clAliceblue $d7ebfa constant clAntiquewhite $ffff00 constant clAqua $d4ff7f constant clAquamarine $fffff0 constant clAzure $dcf5f5 constant clBeige $c4e4ff constant clBisque $000000 constant clBlack $cdebff constant clBlanchedalmond $ff0000 constant clBlue $e22b8a constant clBlueviolet $2a2aa5 constant clBrown $87b8de constant clBurlywood $a09e5f constant clCadetblue $00ff7f constant clChartreuse $1e69d2 constant clChocolate $507fff constant clCoral $ed9564 constant clCornflowerblue $dcf8ff constant clCornsilk $3c14dc constant clCrimson $ffff00 constant clCyan $8b0000 constant clDarkblue $8b8b00 constant clDarkcyan $0b86b8 constant clDarkgoldenrod $a9a9a9 constant clDarkgray $006400 constant clDarkgreen $a9a9a9 constant clDarkgrey $6bb7bd constant clDarkkhaki $8b008b constant clDarkmagenta $2f6b55 constant clDarkolivegreen $008cff constant clDarkorange $cc3299 constant clDarkorchid $00008b constant clDarkred $7a96e9 constant clDarksalmon $8fbc8f constant clDarkseagreen $8b3d48 constant clDarkslateblue $4f4f2f constant clDarkslategray $4f4f2f constant clDarkslategrey $d1ce00 constant clDarkturquoise $d30094 constant clDarkviolet $9314ff constant clDeeppink $ffbf00 constant clDeepskyblue $696969 constant clDimgray $696969 constant clDimgrey $ff901e constant clDodgerblue $2222b2 constant clFirebrick $f0faff constant clFloralwhite $228b22 constant clForestgreen $ff00ff constant clFuchsia $dcdcdc constant clGainsboro $fff8f8 constant clGhostwhite $00d7ff constant clGold $20a5da constant clGoldenrod $808080 constant clGray $008000 constant clGreen $2fffad constant clGreenyellow $808080 constant clGrey $f0fff0 constant clHoneydew $b469ff constant clHotpink $5c5ccd constant clIndianred $82004b constant clIndigo $f0ffff constant clIvory $8ce6f0 constant clKhaki $fae6e6 constant clLavender $f5f0ff constant clLavenderblush $00fc7c constant clLawngreen $cdfaff constant clLemonchiffon $e6d8ad constant clLightblue $8080f0 constant clLightcoral $ffffe0 constant clLightcyan $d2fafa constant clLightgoldenrodyellow $d3d3d3 constant clLightgray $90ee90 constant clLightgreen $d3d3d3 constant clLightgrey $c1b6ff constant clLightpink $7aa0ff constant clLightsalmon $aab220 constant clLightseagreen $face87 constant clLightskyblue $998877 constant clLightslategray $998877 constant clLightslategrey $dec4b0 constant clLightsteelblue $e0ffff constant clLightyellow $c0c0c0 constant clLtGray $a4a0a0 constant clMedGray $808080 constant clDkGray $c0dcc0 constant clMoneyGreen $f0caa6 constant clLegacySkyBlue $f0fbff constant clCream $00ff00 constant clLime $32cd32 constant clLimegreen $e6f0fa constant clLinen $ff00ff constant clMagenta $000080 constant clMaroon $aacd66 constant clMediumaquamarine $cd0000 constant clMediumblue $d355ba constant clMediumorchid $db7093 constant clMediumpurple $71b33c constant clMediumseagreen $ee687b constant clMediumslateblue $9afa00 constant clMediumspringgreen $ccd148 constant clMediumturquoise $8515c7 constant clMediumvioletred $701919 constant clMidnightblue $fafff5 constant clMintcream $e1e4ff constant clMistyrose $b5e4ff constant clMoccasin $addeff constant clNavajowhite $800000 constant clNavy $e6f5fd constant clOldlace $008080 constant clOlive $238e6b constant clOlivedrab $00a5ff constant clOrange $0045ff constant clOrangered $d670da constant clOrchid $aae8ee constant clPalegoldenrod $98fb98 constant clPalegreen $eeeeaf constant clPaleturquoise $9370db constant clPalevioletred $d5efff constant clPapayawhip $b9daff constant clPeachpuff $3f85cd constant clPeru $cbc0ff constant clPink $dda0dd constant clPlum $e6e0b0 constant clPowderblue $800080 constant clPurple $0000ff constant clRed $8f8fbc constant clRosybrown $e16941 constant clRoyalblue $13458b constant clSaddlebrown $7280fa constant clSalmon $60a4f4 constant clSandybrown $578b2e constant clSeagreen $eef5ff constant clSeashell $2d52a0 constant clSienna $c0c0c0 constant clSilver $ebce87 constant clSkyblue $cd5a6a constant clSlateblue $908070 constant clSlategray $908070 constant clSlategrey $fafaff constant clSnow $7fff00 constant clSpringgreen $b48246 constant clSteelblue $8cb4d2 constant clTan $808000 constant clTeal $d8bfd8 constant clThistle $4763ff constant clTomato $d0e040 constant clTurquoise $ee82ee constant clViolet $b3def5 constant clWheat $ffffff constant clWhite $f5f5f5 constant clWhitesmoke $00ffff constant clYellow $32cd9a constant clYellowgreen // =================================================================== // interface to the primitive turtle functions : Clear ( -- ) opClear external ; : Rotate ( v -- ) opRotateDegrees external ; : RotateRad ( v -- ) opRotateRadians external ; : Forward ( v -- ) opForward external ; : Backward ( v -- ) -1.0 * Forward ; : Move ( v -- ) opMove external ; : MoveBack ( v -- ) -1.0 * Move ; : PenUp ( -- ) opPenUp external ; : PenDown ( -- ) opPenDown external ; : Color ( v -- ) opColor external ; : Inflate ( v -- ) opInflate external ; : PushState ( -- ) opPushState external ; alias PushState >s : PopState ( -- ) opPopState external ; alias PopState s> : DupState ( -- ) opDupState external ; alias DupState dup>s : DropState ( -- ) opDropState external ; alias DropState s>drop : SwapState ( -- ) opSwapState external ; alias SwapState sswap : Pen ( v -- ) opPen external ; : Dot ( v -- ) opDot external ; : LClear ( -- ) opLClear external ; : LRule ( cmd exp -- ) opLRule external ; : LMEaning ( cmd exp -- ) opLMeaning external ; : LSystem ( name axiom depth -- ) opLSystem external ; : Extent ( -- L T R B ) opExtent external ; // stuffs 3.0 sqrt constant Sqrt3 5.0 sqrt constant Sqrt5 Sqrt5 1.0 + 2.0 / constant GoldenRatio : DefaultLooks ( -- ) clWhite Color 1 Pen 0 Dot ; : .Extent ( -- ) // Print extent of current graph as Left Top Right Bottom Extent 4 0 do >r loop // rearrange the order ... " Extent(" " l: " + r> >$ + " t: " + r> >$ + " r: " + r> >$ + " b: " + r> >$ + " )" + . ; // =================================================================== // Regular polygons with a specified edge size : Polygon ( size n -- ) >s dup -360.0 swap / ( size n angle ) swap 0 do ( size angle ) dup Rotate ( size angle ) over Forward ( size angle ) loop ( size angle ) 2drop s> ; // some alternate names for the regular Polygons : Triangle ( aSize -- ) 3 Polygon ; : Square ( aSize -- ) 4 Polygon ; : Pentagon ( aSize -- ) 5 Polygon ; : Hexagon ( aSize -- ) 6 Polygon ; : Heptagon ( aSize -- ) 7 Polygon ; : Octagon ( aSize -- ) 8 Polygon ; : Enneagon ( aSize -- ) 9 Polygon ; : Decagon ( aSize -- ) 10 Polygon ; : Hendecagon ( aSize -- ) 11 Polygon ; : Dodecagon ( aSize -- ) 12 Polygon ; // =================================================================== // Some mazes // =================================================================== : _sier ( side level -- side level ) dup 1 <= ( side level ) if ( side level ) swap ( level side ) 3 0 do ( level side ) dup Forward ( level side ) -120.0 Rotate ( level side ) loop ( level side ) swap ( side level ) else ( side level ) 1 - over 2.0 / ( side level-1 side/2) swap recurse swap ( side level-1 side/2) dup Forward ( side level-1 side/2) swap recurse swap ( side level-1 side/2) dup Backward ( side level-1 side/2) -60.0 Rotate ( side level-1 side/2) dup Forward ( side level-1 side/2) 60.0 Rotate ( side level-1 side/2) swap recurse swap ( side level-1 side/2) -60.0 Rotate ( side level-1 side/2) Backward ( side level-1 ) 60.0 Rotate ( side level-1 ) 1 + ( side level ) endif ( side level ) ; : DoSierp ( level -- ) 1.0 swap _sier 2drop ; // =================================================================== : _sier_30_60_90 ( side level -- side level ) dup 1 <= ( side level ) if ( side level ) swap ( level side ) dup Forward ( level side ) 90.0 Rotate ( level side ) dup sqrt3 * Forward 150.0 Rotate dup 2 * Forward 120.0 Rotate swap ( side level ) else ( side level ) 1 - over 2.0 / ( side level-1 side/2) swap recurse swap ( side level-1 side/2) dup Forward ( side level-1 side/2) swap recurse swap ( side level-1 side/2) dup Backward ( side level-1 side/2) -60.0 Rotate ( side level-1 side/2) dup Forward ( side level-1 side/2) 60.0 Rotate ( side level-1 side/2) swap recurse swap ( side level-1 side/2) -60.0 Rotate ( side level-1 side/2) Backward ( side level-1 ) 60.0 Rotate ( side level-1 ) 1 + ( side level ) endif ( side level ) ; : DoSier_30_60_90 ( level -- ) 1.0 swap _sier_30_60_90 2drop ; // =================================================================== : _squest ( side level -- side level ) dup 1 <= ( side level ) if ( side level ) over Triangle else ( side level ) 1 - over 2.0 / ( side level-1 side/ ) dup 2.0 / Hexagon swap recurse swap ( side level-1 side/ ) dup Forward ( side level-1 side/ ) swap recurse swap ( side level-1 side/ ) dup Backward ( side level-1 side/ ) -60.0 Rotate ( side level-1 side/ ) 120.0 Rotate dup 4.0 / Hexagon 240.0 Rotate dup Move ( side level-1 side/ ) 60.0 Rotate ( side level-1 side/ ) dup 2.0 / Hexagon swap recurse swap ( side level-1 side/ ) -60.0 Rotate ( side level-1 side/ ) Backward ( side level-1 ) 60.0 Rotate ( side level-1 ) 1 + ( side level ) endif ( side level ) ; : DoSquest ( level -- ) 1.0 swap _squest 2drop ; // =================================================================== : _penta ( side level -- side level ) dup 0 > ( side level f ) if ( side level ) 1 - ( sided level-1 ) 5 0 do ( side level-1 ) over 2.0 / ( side level-1 side/ ) swap recurse swap ( side level-1 side/ ) drop ( side level-1 ) over Forward ( side level-1 ) -72.0 Rotate ( side level-1 ) loop ( side level-1 ) 1 + ( side level ) endif ( side level ) ; : DoPenta ( level -- ) 1.0 swap _penta 2drop ; // =================================================================== : _hepta ( side level -- side level ) dup 0 > ( side level f ) if ( side level ) 1 - ( sided level-1 ) 7 0 do ( side level-1 ) over 2.0 / ( side level-1 side/ ) swap recurse swap ( side level-1 side/ ) drop ( side level-1 ) over Forward ( side level-1 ) -360.0 7.0 / Rotate ( side level-1 ) loop ( side level-1 ) 1 + ( side level ) endif ( side level ) ; : DoHepta ( level -- ) 1.0 swap _hepta 2drop ; // =================================================================== : _rose ( side level -- side level ) dup 0 > ( side level f ) if ( side level ) 1 - ( side level-1 ) swap ( level-1 side ) 72.0 ( level-1 side angle ) 5 0 do ( level-1 side angle ) over Pentagon dup Rotate loop ( level-1 side angle ) drop 120.0 ( level-1 side angle ) 3 0 do ( level-1 side angle ) over Hexagon ( level-1 side angle ) dup Rotate ( level-1 side angle ) loop ( level-1 side angle ) drop ( level-1 side ) swap ( side level-1 ) over 1.4 / ( side level-1 side/ ) swap recurse swap ( side level-1 side/ ) drop ( side level-1 ) 1 + ( side level ) endif ( side level ) ; : DoRose ( level -- ) 1.0 swap _rose 2drop ; // =================================================================== // // Export the mazes, so they can be selected from Pascal code : Sierpinsky ( -- ) Clear DefaultLooks 5 DoSierp ; export : Penta ( -- ) Clear DefaultLooks 3 DoPenta ; export : Hepta ( -- ) Clear DefaultLooks 3 DoHepta ; export : Squest ( -- ) Clear DefaultLooks 4 DoSquest ; export : Rose ( -- ) Clear DefaultLooks 6 DoRose ; export : Sier_30_60_90 ( -- ) Clear DefaultLooks 5 DoSier_30_60_90 ; export // =================================================================== // // LSystems, systems copied from: // // http://codetrip.weebly.com/blog/year-3-semester-2-procedural-methods-catalogue-of-30-l-systems-drawable-with-turtle-graphics // // : LClear ( -- ) opLClear external ; // : LRule ( cmd exp -- ) opLRule external ; // : LMEaning ( cmd exp -- ) opLMeaning external ; // : LSystem ( name axiom depth -- ) opLSystem external ; LClear " C" " Clear DefaultLooks" LMeaning // Starts a new LSystem, and adds the semantics for clearing the graph " F" " F+F--F+F" LRule // Adds a rule " F" " 1.0 Forward" LMeaning // Adds semantics " +" " -60.0 Rotate" LMeaning " -" " 60.0 Rotate" LMeaning " KochAntiSnowflake" " CF++F++F" 3 LSystem // Define a name, give an axiom and a recursion depth, // create code, compile it, and export it LClear " C" " Clear DefaultLooks" LMeaning " F" " F++F++F|F-F++F" LRule " F" " 1.0 Forward" LMeaning " +" " -36.0 Rotate" LMeaning " -" " 36.0 Rotate" LMeaning " |" " 180.0 Rotate" LMeaning " Pentagonal" " CF++F++F++F++F" 3 LSystem LClear " C" " Clear DefaultLooks" LMeaning " M" " OA++PA----NA[-OA----MA]++" LRule " N" " +OA--PA[---MA--NA]+" LRule " O" " -MA++NA[+++OA++PA]-" LRule " P" " --OA++++MA[+PA++++NA]--NA" LRule " A" " " LRule " A" " 1.0 Forward" LMeaning " +" " -36.0 Rotate" LMeaning " -" " 36.0 Rotate" LMeaning " [" " >s" LMeaning " ]" " s>" LMeaning " Penrose" " C[N]++[N]++[N]++[N]++[N]" 4 LSystem // There is some error in this .. maybe on the web page, maybe here // Anyways .. I still like it LClear " C" " Clear DefaultLooks" LMeaning " F" " BB[++F][F][--F]" LRule " B" " B[++D][--D]B" LRule " D" " F" LRule " X" " F" LRule " F" " 1.0 Forward" LMeaning " B" " 0.5 Forward" LMeaning " D" " 0.5 Forward" LMeaning " +" " -60.0 Rotate" LMeaning " -" " 60.0 Rotate" LMeaning " [" " >s" LMeaning " ]" " s>" LMeaning " I" " 270.0 Rotate" LMeaning " Cubish" " CI[F]-X-[F]-X-[F]-X" 3 LSystem