App-Asciio-1.51.3000755001750000144 012544473514 13147 5ustar00nadimusers000000000000App-Asciio-1.51.3/META.yml000444001750000144 402012544473514 14551 0ustar00nadimusers000000000000--- abstract: 'App::Asciio - ASCII diagramming' author: - 'Khemir Nadim ibn Hamouda. ' build_requires: Directory::Scratch::Structured: '0' Hash::Slice: '0' Test::Block: '0' Test::Exception: '0' Test::NoWarnings: '0' Test::Warn: '0' Text::Diff: '0' configure_requires: Module::Build: '0.42' dynamic_config: 1 generated_by: 'Module::Build version 0.4214, CPAN::Meta::Converter version 2.150001' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: App-Asciio provides: App::Asciio: file: lib/App/Asciio.pm version: '1.51' App::Asciio::GTK::Asciio: file: lib/App/Asciio/GTK/Asciio.pm version: '0.01' App::Asciio::Stencil: file: lib/App/Asciio/Stencil.pm App::Asciio::stripes::angled_arrow: file: lib/App/Asciio/stripes/angled_arrow.pm App::Asciio::stripes::editable_arrow2: file: lib/App/Asciio/stripes/editable_arrow2.pm App::Asciio::stripes::editable_box2: file: lib/App/Asciio/stripes/editable_box2.pm App::Asciio::stripes::if_box: file: lib/App/Asciio/stripes/if_box.pm App::Asciio::stripes::process_box: file: lib/App/Asciio/stripes/process_box.pm App::Asciio::stripes::section_wirl_arrow: file: lib/App/Asciio/stripes/section_wirl_arrow.pm App::Asciio::stripes::single_stripe: file: lib/App/Asciio/stripes/single_stripe.pm App::Asciio::stripes::stripes: file: lib/App/Asciio/stripes/stripes.pm App::Asciio::stripes::wirl_arrow: file: lib/App/Asciio/stripes/wirl_arrow.pm requires: Algorithm::Diff: '0' Clone: '0' Compress::Bzip2: '0' Cwd: '0' Data::Compare: '0' Data::TreeDumper: '0' Data::TreeDumper::Renderer::GTK: '0' Eval::Context: '0' File::Basename: '0' File::Copy: '0' File::Slurp: '0' File::Spec: '0' Glib: '0' Gtk2: '0' Gtk2::Gdk::Keysyms: '0' List::MoreUtils: '0' List::Util: '0' MIME::Base64: '0' Module::Util: '0' Readonly: '0' Sub::Exporter: '0' version: '0.5' resources: license: http://dev.perl.org/licenses/ version: v1.51.3 App-Asciio-1.51.3/Changes000444001750000144 134412544473514 14601 0ustar00nadimusers000000000000commit eafe1b5ab197e0f0a7f4a691a2664a8984a962e9 (HEAD -> master) Author: Nadim Khemir Date: Tue Jun 30 13:02:05 2015 +0200 FIXED: git command in Build.PL commit beb4bd8da8de11c249b61f52cf5e5eb19caad8a4 (origin/master, origin/HEAD) Author: Nadim Khemir Date: Sun Jun 28 14:24:09 2015 +0200 CHANGED: newly added elements are selected commit 192b3212c5dfa12002ed34785b5e262b448272d0 Author: Nadim Khemir Date: Sat Jun 27 22:38:45 2015 +0200 FIX: use /usr/bin/env to start asciio commit edf35e1944bacda8681140ea7fca3b003909f640 Author: Nadim Khemir Date: Sun Sep 16 13:49:28 2012 +0200 ADDED: Asciio version 1.51 App-Asciio-1.51.3/MANIFEST000444001750000144 436712544473514 14447 0ustar00nadimusers000000000000Changes Build.PL Makefile.PL MANIFEST README META.yml README Todo.txt script/asciio_to_text script/A setup/setup.ini setup/actions/align.pl setup/actions/clipboard.pl setup/actions/debug.pl setup/actions/elements_manipulation.pl setup/actions/file.pl setup/actions/mouse.pl setup/actions/new_elements.pl setup/actions/unsorted.pl setup/actions/context_menu_multi_wirl.pl setup/actions/context_menu_box.pl setup/actions/context_menu_rulers.pl setup/actions/colors.pl setup/actions/presentation.pl setup/asciio_object/basic.pl setup/hooks/canonize_connections.pl setup/import_export/ascii.pl setup/import_export/asciioe.pl setup/import_export/perl.pl setup/stencils/asciio setup/stencils/computer setup/stencils/people setup/stencils/divers lib/App/Asciio.pm lib/App/Asciio/Actions.pm lib/App/Asciio/Ascii.pm lib/App/Asciio/Connections.pm lib/App/Asciio/Dialogs.pm lib/App/Asciio/Elements.pm lib/App/Asciio/Io.pm lib/App/Asciio/Menues.pm lib/App/Asciio/Setup.pm lib/App/Asciio/Undo.pm lib/App/Asciio/Options.pm lib/App/Asciio/Stencil.pm lib/App/Asciio/stripes/angled_arrow.pm lib/App/Asciio/stripes/editable_arrow2.pm lib/App/Asciio/stripes/editable_box2.pm lib/App/Asciio/stripes/if_box.pm lib/App/Asciio/stripes/process_box.pm lib/App/Asciio/stripes/section_wirl_arrow.pm lib/App/Asciio/stripes/single_stripe.pm lib/App/Asciio/stripes/stripes.pm lib/App/Asciio/stripes/wirl_arrow.pm lib/App/Asciio/Utils/Presentation.pm t/001_load.t t/002_multi_wirl_connection.t t/003_multi_wirl_diagonal_connection.t t/004_angled_arrows.t documentation/scripting/connected_boxes.pl documentation/scripting/if_objects.pl documentation/scripting/manual_connect.pl documentation/scripting/multi_wirl.pl documentation/scripting/objects.pl documentation/scripting/three_boxes.pl documentation/scripting/lib/scripting_lib.pm documentation/text/depend_and_build.txt documentation/text/permissions.txt documentation/presentation.pl # GTK script/asciio lib/App/Asciio/GTK/Asciio.pm lib/App/Asciio/GTK/Asciio/Dialogs.pm lib/App/Asciio/GTK/Asciio/stripes/wirl_arrow.pm lib/App/Asciio/GTK/Asciio/stripes/editable_box2.pm lib/App/Asciio/GTK/Asciio/stripes/editable_arrow2.pm lib/App/Asciio/GTK/Asciio/Menues.pm setup/GTK/setup.ini setup/GTK/actions/clipboard.pl setup/GTK/import_export/png.pl META.json App-Asciio-1.51.3/Todo.txt000444001750000144 5104012544473514 14772 0ustar00nadimusers000000000000#----------------------# # This is the todo.txt # #----------------------# use json as file format diagonal text is kinky, Ian's request auto connection using A* module http://search.cpan.org/~acdalton/AI-Pathfinding-AStar-0.10/ - orthogonal or orthogonal and diagonal arrows - add get_cost_map to base Asciio - get_cost_map can also be implemented in draw in sub classes - connectors and elements could have different costs Optimize the connection optimizer - no optimization needed for unchanged objects - asciio must keep track of changed objects - but we must not be intruisive - md5 ?? re-parsable asciio output with minimal data read http://www-cs-students.stanford.edu/~amitp/gameprog.html Path finding, see ISBN 2550-0124977820 add actions: - select all elements connected to currently selected element(s) - select all elemet connected to the element under the pointer - expend selection level with '+', also implement '-', '*', ... - optimize current arrow (A* pathfinder) - click + key on arrow adds a 'flex' point what's new section night colors don't change the ruler colors ? generate "nice looking" graph - interface to ditaa - HTML document?! copy to clipboard removes empty lines at the begining of the buffer two section arrow middle connector keeps horizontal with linked element this would reduce the amount of changes that need to be done manually Curses UI tutorial add offset input to multiple element creation window slide mode accept a directory as input show slides based on sort order or order.slide.txt allow saving of modified slides allow deletion and insertion of slides what if the slides are under git control? extra window to show slide order and modify it (and the slides maybe) extra slide menu (through actions) open save insert delete arrow menu not working document what ascii_events should contain links to gtk doc should the content itself be defined in the derived class? split into two distributions? => easier for those who want to build another interface setup/actions manipulating asciio object directely move to asciio transparent background for cmd output width > spaces == transparent spaces => transparent 0 => transparent merge arrows and split arrow arrow merge object like a single character text but nicer to use with arrows or merge arrow connections directely (weld them together) multi-ended connectors add remove end from multi ended connectors start and end connectors should have different colors copy elements to the system clipboard to allow copies between instances handle multiple versions with one of the following mechanisms: - embed git::PurePerl - use PAR - multiple directories Display version somewhere connected, non auto-connect, arrows loose their connection if the connectee is resized => this is because resize doesn't keep the connection. The canonizer reconnects elements but non auto-connect objects are not handled by the canonizer => make canonizer re connect to the same place instead for changing the connector magnet object for ESD reload color options after loading file display_grid + element_backgound_color search for stripe class in the setup directory or list the directories in the setup or add the directory as setup data and 'use lib' let actions load stencils forward KB + mouse events to stripes objects table object bulleted lists and otherwise formatted text record box object save as pdf and printing more than one resize handle zoom on pointer #not ctl to zoom panning scrollbars autosave connector grouping cancel button in editing windows handle unicode (remove write_file) now arrow can match inside a box, moving an arrow around has become more tricky => do not connect if both ends are unconnected and arrow is being moved move action constants to module optimize do_stack serialization # use bzip2 => diff + compress # tests done must have a reverse diff that can patch both ways or it's not worth it Management mode => make ascii look like not ascii => use ANSI X3.64 connections connected to a start and an end connector are displayed with warning color move to display plugins => how do we handle double pointed arrows? #------------------- done ---------------------------- #insertion from context menu doesn't select inserted element while shortcut does # color scheme #linux => black #systmem => white # flashing connection color is user setable !change name extra_point to resize_handle_color #error asciio_ui.asciio doesn't display properly in unix color scheme => not an error, color was specificaly set # autoshrink is default # multi element creation keep the element selected # insert section in middle of multi wirl arrow # inserted diagrams have weird connections that do not move in synch with mouse # implement inset diagram in slides # separate gtk parts from asciio Asciio.pm and Asciio::GTK.pm move gtk dialog from stripe classes # save window size in file # convert asciio stencil to new format also needed because changes to code is not reflected in stencil # let user query which keyboard shortcut is still free generate a list instead (with links to existing actions and their files) => display keyboard mapping in unsorted.pl; shortcut 'k'. # error: changing arrow type changed the directions of sections # option to disable auto linking on box element (only possible on arrow right now) # Error: add boxes, undo all, redo all, exit => no confirmation asked! # Error: previously saved files (network) do not load new stencils # resize the selected element if any not the top most temporary_move_selected_element_to_front may be a less surprising way to achieve the same result # shift + click should deselect the object under the cursor => only works when one single element # insert template diagrams not only elements => control + i #angled-up arrow .---- N::B::T::T::UDP / .-------- N::B::T::Tracker / \ / .-- N::B::T::File `--- N::B::T::T::HTTP / / .---- Net::BitTorrent::Torrent / / .--- Net::BitTorrent::DHT / / \ Net::BitTorrent `---- N::B::D::Node \ `---- Net::BitTorrent::Peer # multiple box insert command should not insert boxes without text this allows us to have many more separators in the default list => accept \n as separator #auto resize after text changes? auto resize as an attribute to the box # selection that doesn't take arrows ! move to row column named ruler #save stencil one by one => give name to objects => save selected to stencils #stencil directory #if a directory is listed in the stencil section of the setup file, all the stencils in that directory are loaded #directory name should be added to the element name #ASCII in the context menue should be replaced by stencils or whatever directory is the root #network stencils missing small wireless #auto stencil stencils are 'run' this means that they can be created from other data #remove section at the begining of the arrow #add section at the begining of the arrow => auto connection works but moving the connected object -> error #dialogs #button missing icons !assign ctl + enter as OK in edit boxes => alt + C #vertical text !signing objects and diagrams? #toggle grid #text object should be resized to the text size when created #allow non auto-connect to be one character around the object instead for _on_ the object => this could be handled by the box object - the box object is asked to match a connector - the box object can dynamically create a connector - if the box object is resized, the connectors can be moved the connectors can remember their position if the box object is resized again - new connection should connect new connectors => we need to know who we are connecting to => or this could be done by the asciio object - asciio asks the box to add a connection this let ascioo decide where they should be placed instead for deciding it's around the box - the user can add connectors with the same mechanism - the connector must be handled when resizing the box object by the box object or by the connector itself #Box added via 'B' shortcut should be selected #reselect elements after quick link #select text an focus in text editing window #error: title has frame when text doesn't #link to camel box #background color, grid color #save file in exit dialog #continuation _from_ diagonal is not correct !allow diagonals in setup #diagonal lines #error: connector character is wrong #dynamically choose if the arrow allows diagonal or not (keyboard) #handle error when running external command Can't exec "dsq": No such file or directory at '/devel/perl_modules/App/Asciio/blib/lib/App/Asciio/setup//actions/unsorted.pl' line 365. Use of uninitialized value in split at /devel/perl_modules/App/Asciio/blib/lib/App/Asciio/stripes/editable_box2.pm line 50. #paste at the mouse position #per arrow autoconnect #dynamically add connectors #copy selected elements to clipboard #move ruler line definition to the setup allow removal of rulers allow specific location of rulers #dynamically generate GROUP_COLORS #figlet support Done via external command Emanuel Haupt Useless use of a constant in void context at /usr/lib64/perl5/site_perl/5.8.8/Text/FIGlet.pm line 177. hundreds of : Use of uninitialized value in substitution (s///) at /usr/lib64/perl5/site_perl/5.8.8/Text/FIGlet.pm line 93. Use of uninitialized value in concatenation (.) or string at /usr/lib64/perl5/site_perl/5.8.8/Text/FIGlet.pm line 95. Use of uninitialized value in string ne at /usr/lib64/perl5/site_perl/5.8.8/Text/FIGlet.pm line 154. Use of uninitialized value in string eq at /usr/lib64/perl5/site_perl/5.8.8/Text/FIGlet.pm line 163. Use of uninitialized value in string ne at /usr/lib64/perl5/site_perl/5.8.8/Text/FIGlet.pm line 200. #non connecting section wirl arrows #external command output Emanuel Haupt #screencast demo #remove section #export png #possibility to close the application from a script #return edits the currently selected box #error: targets are not opened #register_action_handlers return own data not the evaled package #script to generate a list of the actions available #error: |------------> #error: moving connectors on each other bugs the connector size only when end connector is backed over start connector #error: multi wirl inter-sections overlays should be taken from the arrow definition # .#### | # #####-## #direction change should work on any arrow section #error: Add section keeps connection #error: Add section doesn't connect # multi wirl extension as if we were drawing the arrow when the mouse takes a turn, a wirl point is added => or add section when clicked #Add section to cursor position #add easy way, through a shortcut, to: #change arrow type dots, equal, star, ... !make an arrow a muti wirl arow => use only multi wirl arrow #box a text #change box type # keep selection mode selected == index not boolean #display action definition file #Remove single wirl arrow object #=> a connection error occures when using a multiple wirl object with a single wirl write a test where two boxes are connected with one type of arrow and two other boxes with the other type of arrow, move the boxes around and compare the display # flip broken #change direction broken #test scripting lib #scripting lib difficult to locate => -Mblib broken too ADDED: option parsing #multi level action do not work anymore #contex menu box has errors Use of uninitialized value in numeric lt (<) at '/devel/perl_modules/App/Asciio/blib/lib/App/Asciio/setup//actions/context_menu_box.pl' line 118. Use of uninitialized value in array element at '/devel/perl_modules/App/Asciio/blib/lib/App/Asciio/setup//actions/context_menu_box.pl' line 120. #parse switches #setup path #file name is not remembered on, first Save As ! not kept in the undo buffer be carefull to not override SaveAs file name => don't go to previous file name if it was saved As #flip start and end of arrows #action can register themselves so they can add entries in context menues #CREATE_BACKUP is saved and restored with the files! #arrow pointing in both direction #wirl #multi wirl #quick insert short cut for both #do pod saving and loading without external commands and files #remove the cp command call and other backticks #connected box.pl with 3 boxes doesn't canonize the links properly note that we are giving a missleading hint to start with => connections are right !record gpad with do_stack and add a play_gpad script => better to save screenshots that are taken when using a keyboard shortcut => we can also record snippets, by recording at each create_undo_snapshot => use screencast #exporting an imported pod generates a slightly different base64 check a gpade dump => Dumper had different order #error when copying element that has connections appeared after quick link implementation connection seems to be wrong as it moves with the copied element but is not connected difficult to reproduce #shortcut to change the direction of an arrow instead for using wirl !auto connect with quick link uses the closest to the pointer give hint to wirl creation => better to be consistent. preference can be given in actions/mouse.pl #action shortcut should not be gtk dependent # remove redo_stack_maximum_size #action should register a name we can call them with instead for calling them by keyboard mapping #move %loaded_types in gpad_io to object #save file sets title, or not #gpad format is unreadable anyway, compress #gpade import/export remove gpade from gpad # importer can set the title #open save POD #use work directory #remove all unecessary use from the action files #open save export as plugins #saving as xx.txt will not save anything in gpad anymore ! add --setup to locate the setup directory => use file::Repository => use getopt #override/move gpad internally set variables with variables set in the setup files #=> wait till tab to space is defined #command to generate a stencil ready definition from the current state of an object => load multiple stencils and keep the filesystem structure in the popup menues => allow shortcut to be associated with the stencil elements (by name and in setup files) #drawing arrow into box connects the arrow #transfor tabs to space #only allow start-end connectors to link for multiwirl but allow moving of the intermediate connectors #shortcut that adds elements but opens the edit dialog directly before inserting the object should this be the default for object creation from stencils? => shall we add a EDIT_ON_CREATE fields= #ctl + shift + arrows => connect arrows as connect boxes does #color groups when using solid background => through a get_element_background_color #error shift plus select area doesn't work #do notshow resize rectangle if attribut is not set #error after aligning box centers, the connectors are real weird in if_elsif.gpad #verify all the '* $character_' and '\ $character_' #editing box breaks the connections #?use DTD::GTK for dumps !? table element => user defined plugin in the future !one character element should move not resize #keyboard mapping #automatic moving of start connector is weird => $moved_connector_name #-init #export is broken since 'save as' #handle file save properly #save unnamed to new name OK #save unnamed to old name ASK FOR OVERRIDE PERMISSION #save named DO NOT ASK NAME #save as WORKS as save UNAMED #save mark document as NOT MODIFIED (check undo still works) #redo #quick insert for text (same as quick insert for boxes) #save element's X Y in character sizes #access stencil elements by name !add module with shared constants (ie setup) => later #update_diagram should be configurable make a module so we can optimize a connection at the time canonize uses $self for character size only ? ask for the optimal connection before creating it #subs to connect specific connectors wherever the elements are and they are sized #script using cononize_connection doesn't work, path was changed #make a script library !update_diagram should be called when running in script mode let the script writer decide if they want "optimized" connections or not # proper setup structure #editable arrow has connections!! use resize/info/highlight points instead # export ASCII to clipboard #quick connect if selected elements connect element under to selected elements deselect all else select element #forward mouse to ACTIONS #$dragging moved to class setting it should be possible through an API #auto connect that moves an arrow start should update the end connector #multi wirl in default gpad.pl #alignment tool #single group element copied still thinks it part of a group #changing text in if reconnect wrong #set/get_text #default glyph types for box #setting X, Y in scipts doesn't generate expected ASCII output #connector error in multi wirl #transfor to ASCII output has extra spaces #multiline arrow take direction for every point (for scripting) !--script my_script.pl #save on exit if modified #multiline arrow !reapeat box given a text, it will repeat it depednding on the size !full multiples or not #process box #segfault #can't use Data::TreeDumper in copy to clipboard # 'new connection' is flashed for a connector that is already connected #tab to select first element generate 'uninitialzed value at 134' #undo #do not save undo buffer #copy doesn't keep connections #front back break connections #keyboard move doesn't move connections !cycle color for selection points like for groups? #move $previous_x, $previous_y to the class #error: drawing connections on move #error: drawing connections on resize box #error: drawing connections on edit #refactor other end offsetting (used in move and resize) #missing: save connections #error moving groups looses connection #thrown a few boxes and arrows in an empty document #keyboard short cut transparent mode show connectors connections #resize connectee doesn't move the connector #move group looses connections #resizing downright arrow flips it to rightdown handle multiple character start and end in angled arrow handle \t in text #after changing line glyphs, it becomes right down from right up !! #ungrouping moves object up selecting a single group element, through selection rectangle, selects the whole group right? #saving named objects uses the objects contents for the next copy #save doesn't save grouping !! save elements without NAME to avoid overriding object at load time ?? seems that selection rectangle sometimes doesn't work #selection is done botom up instead for the opposite! #when bg selection is on, can't select fg selecting an element that is between two grouped elements is not possible !selection cycles through objects when clicking + tab #BOX2 with title and text only displays wrong size #box and arrow streching are not ont the same box doesn't accept row 0 #can't loade face file #edit text to empty string #if only one element is editable in a group, edit it present selection box if multiple editable objects #handle \ in text for pango #_ is removed from name in menues spell cheker #grouping Window size in character multiples Drag drop objects from views or other aflow instance Select font Colored font Background color #Stencils are normal files #Grouping, alignment, send back/front #Grid display #Horizontal and vertical alignement lines !Objects are hilighted when overed (incuding groups) #Select and move object with a single click #Multiple object selection Save in multiple format, try to keep extra attributes like color         text, raw text, html !Object is an instance of a class         node can change class (eg from square to round)         class can be modified (eg color change for all nodes) Node class defines the node's apparence, class is a script User defined key mapping, mouse mapping and menu mapping #Static object mode         select object(s) and click to insert it without drag drop Layers?         each layer has its tab and one can see through tabs         how does this play with split window Scripts can add their mappings Scripts can generate new graphs Re-order script so objects without link are aligned under each other Routing and reordering script Script can be save in stencil Drag drop script object executes it App-Asciio-1.51.3/Build.PL000444001750000144 1330612544473514 14623 0ustar00nadimusers000000000000 use strict ; use warnings ; use Module::Build; my %all_modules ; my @split_modules ; my @pm_files = qw( lib/App/Asciio.pm lib/App/Asciio/Actions.pm lib/App/Asciio/Ascii.pm lib/App/Asciio/Connections.pm lib/App/Asciio/Dialogs.pm lib/App/Asciio/Elements.pm lib/App/Asciio/Io.pm lib/App/Asciio/Menues.pm lib/App/Asciio/Setup.pm lib/App/Asciio/Undo.pm lib/App/Asciio/Options.pm lib/App/Asciio/Stencil.pm lib/App/Asciio/stripes/angled_arrow.pm lib/App/Asciio/stripes/editable_arrow2.pm lib/App/Asciio/stripes/editable_box2.pm lib/App/Asciio/stripes/if_box.pm lib/App/Asciio/stripes/process_box.pm lib/App/Asciio/stripes/wirl_arrow.pm lib/App/Asciio/stripes/section_wirl_arrow.pm lib/App/Asciio/stripes/single_stripe.pm lib/App/Asciio/stripes/stripes.pm lib/App/Asciio/Utils/Presentation.pm lib/App/Asciio/GTK/Asciio.pm lib/App/Asciio/GTK/Asciio/Dialogs.pm lib/App/Asciio/GTK/Asciio/Menues.pm lib/App/Asciio/GTK/Asciio/stripes/editable_arrow2.pm lib/App/Asciio/GTK/Asciio/stripes/wirl_arrow.pm lib/App/Asciio/GTK/Asciio/stripes/editable_box2.pm ); for(@pm_files) { $all_modules{$_} = $_ ; push @split_modules, $_ ; } my @setup_lib= qw( setup/setup.ini setup/actions/align.pl setup/actions/clipboard.pl setup/actions/debug.pl setup/actions/elements_manipulation.pl setup/actions/file.pl setup/actions/mouse.pl setup/actions/new_elements.pl setup/actions/colors.pl setup/actions/unsorted.pl setup/actions/presentation.pl setup/actions/context_menu_multi_wirl.pl setup/actions/context_menu_box.pl setup/actions/context_menu_rulers.pl setup/asciio_object/basic.pl setup/hooks/canonize_connections.pl setup/import_export/ascii.pl setup/import_export/asciioe.pl setup/import_export/perl.pl setup/stencils/asciio setup/stencils/computer setup/stencils/people setup/stencils/divers setup/GTK/setup.ini setup/GTK/actions/clipboard.pl setup/GTK/import_export/png.pl ) ; for(@setup_lib) { $all_modules{$_} = "lib/App/Asciio/$_" ; } sub GetVersionAndRevisionFrom { my ($file) = @_ ; my $version_from = File::Spec->catfile( split '/', $file ); my $version = Module::Build->version_from_file($version_from); if($ENV{'App_Asciio_USE_GIT_VERSION_FOR_DIST'}) { my $number_of_commits = `git log | grep -E 'commit [0-9a-f]{40}' | wc -l` ; chomp $number_of_commits ; if($number_of_commits) { #print "number of git revision: $number_of_commits.\n" ; return("${version}.${number_of_commits}") ; } else { print "Couldn't get git revision, using version from '$file'!\n" ; return($version) ; } } else { return($version) ; } } my $code = <<'EOC'; use strict ; use warnings ; sub GetVersionAndRevisionFrom { my ($file) = @_ ; my $version_from = File::Spec->catfile( split '/', $file ); my $version = Module::Build->version_from_file($version_from); if($ENV{'App_Asciio_USE_GIT_VERSION_FOR_DIST'}) { my $number_of_commits = `git log | grep -E 'commit [0-9a-f]{40}' | wc -l` ; chomp $number_of_commits ; if($number_of_commits) { #print "number of git revision: $number_of_commits.\n" ; return("${version}.${number_of_commits}") ; } else { print "Couldn't get git revision, using version from '$file'!\n" ; return($version) ; } } else { return($version) ; } } sub ACTION_author_test { my $self = shift; local $self->{properties}{test_files} = 'xt/author/*.t' ; $self->SUPER::ACTION_test(); } sub ACTION_build { my $self = shift; if($ENV{'App_Asciio_USE_GIT_VERSION_FOR_DIST'}) { my ($version) = GetVersionAndRevisionFrom('lib/App/Asciio.pm') ; #~ print "Generating version module ($version)\n" ; open VERSION, '>', 'Version.pm' or die "can't generate Version module: $!\n" ; print VERSION <SUPER::ACTION_build(@_); } sub ACTION_dist { my $self = shift; if($ENV{'App_Asciio_USE_GIT_VERSION_FOR_DIST'}) { my $have_git = $self->do_system('git --version'); if($have_git) { print `git status -s --ignored`; if($self->do_system('git log --decorate > git_Changes')) { use File::Copy; move('git_Changes', 'Changes') ; } else { print "Couldn't get git log, 'Changes' will not be generated from git log!\n" ; } } else { print "git not found, 'Changes' will not be generated from git log!\n" ; } } $self->SUPER::ACTION_test() ; #~ $self->ACTION_author_test() ; $self->SUPER::ACTION_dist(); }; EOC my $class = Module::Build->subclass(class => 'App::Asciio', code => $code) ; my $build = $class->new ( module_name => 'App::Asciio', dist_version => GetVersionAndRevisionFrom('lib/App/Asciio.pm'), license => 'perl', build_requires => { 'Text::Diff' => 0, 'Test::Block' => 0, 'Test::Exception' => 0, 'Test::NoWarnings' => 0, 'Test::Warn' => 0, 'Directory::Scratch::Structured' => 0, 'Hash::Slice' => 0, }, requires => { 'Readonly' => 0, 'Data::Compare' => 0, 'Sub::Exporter' => 0, 'Data::TreeDumper' => 0, 'version' => 0.50, 'Glib' => 0, 'Gtk2' => 0, 'Gtk2::Gdk::Keysyms' => 0, 'Data::TreeDumper::Renderer::GTK' => 0, 'Compress::Bzip2' => 0, 'Cwd' => 0, 'Eval::Context' => 0, 'File::Basename' => 0, 'File::Spec' => 0, 'List::MoreUtils' => 0, 'List::Util' => 0, 'MIME::Base64' => 0, 'File::Copy' => 0, 'File::Slurp' => 0, 'Algorithm::Diff' => 0, 'Clone' => 0, 'Module::Util' =>0, }, pm_files => \%all_modules, #~ autosplit => \@split_modules, script_files => ['script/asciio', 'script/asciio_to_text', 'script/A',], dist_author => 'Khemir Nadim ibn Hamouda. ', dist_abstract => 'App::Asciio - ASCII diagramming', ); $build->create_build_script; App-Asciio-1.51.3/META.json000444001750000144 611512544473514 14730 0ustar00nadimusers000000000000{ "abstract" : "App::Asciio - ASCII diagramming", "author" : [ "Khemir Nadim ibn Hamouda. " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4214", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "App-Asciio", "prereqs" : { "build" : { "requires" : { "Directory::Scratch::Structured" : "0", "Hash::Slice" : "0", "Test::Block" : "0", "Test::Exception" : "0", "Test::NoWarnings" : "0", "Test::Warn" : "0", "Text::Diff" : "0" } }, "configure" : { "requires" : { "Module::Build" : "0.42" } }, "runtime" : { "requires" : { "Algorithm::Diff" : "0", "Clone" : "0", "Compress::Bzip2" : "0", "Cwd" : "0", "Data::Compare" : "0", "Data::TreeDumper" : "0", "Data::TreeDumper::Renderer::GTK" : "0", "Eval::Context" : "0", "File::Basename" : "0", "File::Copy" : "0", "File::Slurp" : "0", "File::Spec" : "0", "Glib" : "0", "Gtk2" : "0", "Gtk2::Gdk::Keysyms" : "0", "List::MoreUtils" : "0", "List::Util" : "0", "MIME::Base64" : "0", "Module::Util" : "0", "Readonly" : "0", "Sub::Exporter" : "0", "version" : "0.5" } } }, "provides" : { "App::Asciio" : { "file" : "lib/App/Asciio.pm", "version" : "1.51" }, "App::Asciio::GTK::Asciio" : { "file" : "lib/App/Asciio/GTK/Asciio.pm", "version" : "0.01" }, "App::Asciio::Stencil" : { "file" : "lib/App/Asciio/Stencil.pm" }, "App::Asciio::stripes::angled_arrow" : { "file" : "lib/App/Asciio/stripes/angled_arrow.pm" }, "App::Asciio::stripes::editable_arrow2" : { "file" : "lib/App/Asciio/stripes/editable_arrow2.pm" }, "App::Asciio::stripes::editable_box2" : { "file" : "lib/App/Asciio/stripes/editable_box2.pm" }, "App::Asciio::stripes::if_box" : { "file" : "lib/App/Asciio/stripes/if_box.pm" }, "App::Asciio::stripes::process_box" : { "file" : "lib/App/Asciio/stripes/process_box.pm" }, "App::Asciio::stripes::section_wirl_arrow" : { "file" : "lib/App/Asciio/stripes/section_wirl_arrow.pm" }, "App::Asciio::stripes::single_stripe" : { "file" : "lib/App/Asciio/stripes/single_stripe.pm" }, "App::Asciio::stripes::stripes" : { "file" : "lib/App/Asciio/stripes/stripes.pm" }, "App::Asciio::stripes::wirl_arrow" : { "file" : "lib/App/Asciio/stripes/wirl_arrow.pm" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "v1.51.3" } App-Asciio-1.51.3/README000444001750000144 22612544473514 14144 0ustar00nadimusers000000000000Asciio ==== INSTALLATION ------------ To install this module type the following: perl Build.PL ./Build ./Build test ./Build install App-Asciio-1.51.3/Makefile.PL000444001750000144 23212544473514 15233 0ustar00nadimusers000000000000 use strict ; use warnings ; use Module::Build::Compat; Module::Build::Compat->run_build_pl(args => \@ARGV); Module::Build::Compat->write_makefile(); App-Asciio-1.51.3/setup000755001750000144 012544473514 14307 5ustar00nadimusers000000000000App-Asciio-1.51.3/setup/setup.ini000444001750000144 130512544473514 16304 0ustar00nadimusers000000000000{ STENCILS => [ 'stencils/asciio', 'stencils/computer', 'stencils/people', 'stencils/divers', ], ACTION_FILES => [ 'actions/align.pl', 'actions/clipboard.pl', 'actions/debug.pl', 'actions/new_elements.pl', 'actions/elements_manipulation.pl', 'actions/file.pl', 'actions/mouse.pl', 'actions/colors.pl', 'actions/unsorted.pl', 'actions/presentation.pl', 'actions/context_menu_multi_wirl.pl', 'actions/context_menu_box.pl', 'actions/context_menu_rulers.pl', ], HOOK_FILES => [ 'hooks/canonize_connections.pl', ], ASCIIO_OBJECT_SETUP => [ 'asciio_object/basic.pl', ], IMPORT_EXPORT => [ 'import_export/ascii.pl', 'import_export/perl.pl', 'import_export/asciioe.pl', ], } App-Asciio-1.51.3/setup/actions000755001750000144 012544473514 15747 5ustar00nadimusers000000000000App-Asciio-1.51.3/setup/actions/elements_manipulation.pl000444001750000144 2502112544473514 23055 0ustar00nadimusers000000000000 #---------------------------------------------------------------------------------------------- register_action_handlers ( 'Select next element' => ['000-Tab', \&select_next_element], 'Select previous element' => ['00S-ISO_Left_Tab', \&select_previous_element], 'Select all elements' => ['C00-a', \&select_all_elements], 'Delete selected elements' => ['000-Delete', \&delete_selected_elements], 'Group selected elements' => ['C00-g', \&group_selected_elements], 'Ungroup selected elements' => ['C00-u', \&ungroup_selected_elements], 'Move selected elements to the front' => ['C00-f', \&move_selected_elements_to_front], 'Move selected elements to the back' => ['C00-b', \&move_selected_elements_to_back], 'Temporary move selected element to the front' => ['0A0-f', \&temporary_move_selected_element_to_front], 'Edit selected element' => ['000-Return', \&edit_selected_element], 'Move selected elements left' => ['000-Left', \&move_selection_left], 'Move selected elements right' => ['000-Right', \&move_selection_right], 'Move selected elements up' => ['000-Up', \&move_selection_up], 'Move selected elements down' => ['000-Down', \&move_selection_down], 'Change arrow direction' => ['000-d', \&change_arrow_direction], 'Flip arrow start and end' => ['000-f', \&flip_arrow_ends], ) ; #---------------------------------------------------------------------------------------------- sub edit_selected_element { my ($self) = @_ ; my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements == 1) { $self->create_undo_snapshot() ; $self->edit_element($selected_elements[0]) ; $self->update_display(); } } #---------------------------------------------------------------------------------------------- sub change_arrow_direction { my ($self) = @_ ; $self->create_undo_snapshot() ; my $changes_made = 0 ; # App::Asciio::stripes::section_wirl_arrow my @elements_to_redirect = grep {ref $_ eq 'App::Asciio::stripes::section_wirl_arrow'} $self->get_selected_elements(1) ; if(@elements_to_redirect) { $changes_made++ ; for (@elements_to_redirect) { $_->change_section_direction($self->{MOUSE_X} - $_->{X}, $self->{MOUSE_Y} - $_->{Y}) ; } } # App::Asciio::stripes::angled_arrow @elements_to_redirect = grep {ref $_ eq 'App::Asciio::stripes::angled_arrow'} $self->get_selected_elements(1) ; if(@elements_to_redirect) { $changes_made++ ; for (@elements_to_redirect) { $_->change_direction() ; } } # all if($changes_made) { $self->update_display() ; } else { $self->pop_undo_buffer(1) ; } } #---------------------------------------------------------------------------------------------- sub flip_arrow_ends { my ($self) = @_ ; my @elements_to_flip = grep { my @connectors = $_->get_connector_points() ; ref $_ eq 'App::Asciio::stripes::section_wirl_arrow' && $_->get_number_of_sections() == 1 && @connectors > 0 ; } $self->get_selected_elements(1) ; if(@elements_to_flip) { $self->create_undo_snapshot() ; my %reverse_direction = ( 'up', => 'down', 'right' => 'left', 'down' => 'up', 'left' => 'right' ) ; for (@elements_to_flip) { # create one with ends swapped my $new_direction = $_->get_section_direction(0) ; if($new_direction =~ /(.*)-(.*)/) { my ($start_direction, $end_direction) = ($1, $2) ; $new_direction = $reverse_direction{$end_direction} . '-' . $reverse_direction{$start_direction} ; } else { $new_direction = $reverse_direction{$new_direction} ; } my ($start_connector, $end_connector) = $_->get_connector_points() ; my $arrow = new App::Asciio::stripes::section_wirl_arrow ({ %{$_}, POINTS => [ [ - $end_connector->{X}, - $end_connector->{Y}, $new_direction, ] ], DIRECTION => $new_direction, }) ; #add new element, connects automatically $self->add_element_at($arrow, $_->{X} + $end_connector->{X}, $_->{Y} + $end_connector->{Y}) ; # remove element $self->delete_elements($_) ; # keep the element selected $self->select_elements(1, $arrow) ; } $self->update_display() ; } } #---------------------------------------------------------------------------------------------- sub select_next_element { my ($self) = @_ ; return unless exists $self->{ELEMENTS}[0] ; $self->create_undo_snapshot() ; my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements) { my $last_selected_element = $selected_elements[-1] ; my ($seen_selected, $next_element) ; for my $element (@{$self->{ELEMENTS}}) { if(! $self->is_element_selected($element) && $seen_selected) { $next_element = $element ; last ; } $seen_selected =$element == $last_selected_element ; } $self->deselect_all_elements() ; if($next_element) { $self->select_elements(1, $next_element) ; } else { $self->select_elements(1, $self->{ELEMENTS}[0]); } } else { $self->select_elements(1, $self->{ELEMENTS}[0]); } $self->update_display() ; } #---------------------------------------------------------------------------------------------- sub select_previous_element { my ($self) = @_ ; return unless exists $self->{ELEMENTS}[0] ; $self->create_undo_snapshot() ; my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements) { my $last_selected_element = $selected_elements[0] ; my ($seen_selected, $next_element) ; for my $element (reverse @{$self->{ELEMENTS}}) { if(! $self->is_element_selected($element) && $seen_selected) { $next_element = $element ; last ; } $seen_selected =$element == $last_selected_element ; } $self->deselect_all_elements() ; if(defined $next_element) { $self->select_elements(1, $next_element) ; } else { $self->select_elements(1, $self->{ELEMENTS}[-1]); } } else { $self->select_elements(1, $self->{ELEMENTS}[-1]); } $self->update_display() ; } #---------------------------------------------------------------------------------------------- sub select_all_elements { my ($self) = @_ ; $self->select_all_elements() ; $self->update_display() ; } ; #---------------------------------------------------------------------------------------------- sub delete_selected_elements { my ($self) = @_ ; $self->create_undo_snapshot() ; $self->delete_elements($self->get_selected_elements(1)) ; $self->update_display() ; } ; #---------------------------------------------------------------------------------------------- sub move_selection_left { my ($self, $offset) = @_ ; $offset = 1 unless defined $offset ; $self->create_undo_snapshot() ; $self->move_elements(-$offset, 0, $self->get_selected_elements(1)) ; $self->update_display() ; } ; #---------------------------------------------------------------------------------------------- sub move_selection_right { my ($self, $offset) = @_ ; $offset = 1 unless defined $offset ; $self->create_undo_snapshot() ; $self->move_elements($offset, 0, $self->get_selected_elements(1)) ; $self->update_display() ; } ; #---------------------------------------------------------------------------------------------- sub move_selection_up { my ($self, $offset) = @_ ; $offset = 1 unless defined $offset ; $self->create_undo_snapshot() ; $self->move_elements(0, -$offset, $self->get_selected_elements(1)) ; $self->update_display() ; } ; #---------------------------------------------------------------------------------------------- sub move_selection_down { my ($self, $offset) = @_ ; $offset = 1 unless defined $offset ; $self->create_undo_snapshot() ; $self->move_elements(0, $offset, $self->get_selected_elements(1)) ; $self->update_display() ; } ; #---------------------------------------------------------------------------------------------- sub group_selected_elements { my ($self) = @_ ; my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements >= 2) { $self->create_undo_snapshot() ; my $group = {'GROUP_COLOR' => $self->get_group_color()} ; for my $element (@selected_elements) { push @{$element->{'GROUP'}}, $group ; } } $self->update_display() ; } ; #---------------------------------------------------------------------------------------------- sub ungroup_selected_elements { my ($self) = @_ ; my @selected_elements = $self->get_selected_elements(1) ; for my $grouped (grep {exists $_->{GROUP} } @selected_elements) { pop @{$grouped->{GROUP}} ; } $self->update_display() ; } ; #---------------------------------------------------------------------------------------------- sub move_selected_elements_to_front { my ($self) = @_ ; my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements) { $self->create_undo_snapshot() ; $self->move_elements_to_front(@selected_elements) ; } $self->update_display() ; } ; #---------------------------------------------------------------------------------------------- sub move_selected_elements_to_back { my ($self) = @_ ; my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements) { $self->create_undo_snapshot() ; $self->move_elements_to_back(@selected_elements) ; } $self->update_display() ; } ; #---------------------------------------------------------------------------------------------- sub temporary_move_selected_element_to_front { my ($self) = @_ ; if(defined $self->{ACTIONS_STORAGE}{temporary_move_selected_element_to_front}) { my ($element, $position) = @{$self->{ACTIONS_STORAGE}{temporary_move_selected_element_to_front}} ; my $current_position = 0 ; for (@{$self->{ELEMENTS}}) { if($element == $_) { $self->create_undo_snapshot() ; splice @{$self->{ELEMENTS}}, $current_position, 1 ; splice @{$self->{ELEMENTS}}, $position, 0, $element ; $self->update_display() ; last ; } $current_position++ ; } delete $self->{ACTIONS_STORAGE}{temporary_move_selected_element_to_front} ; } else { my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements == 1 ) { $self->create_undo_snapshot() ; my $selected_element = $selected_elements[0] ; my $position = 0 ; for (@{$self->{ELEMENTS}}) { last if $selected_element == $_ ; $position++ ; } $self->move_elements_to_front($selected_element) ; $self->{ACTIONS_STORAGE}{temporary_move_selected_element_to_front} = [$selected_element, $position] ; $self->update_display() ; } } } ; App-Asciio-1.51.3/setup/actions/clipboard.pl000444001750000144 446312544473514 20407 0ustar00nadimusers000000000000 use List::Util qw(min max) ; #---------------------------------------------------------------------------------------------- register_action_handlers ( 'Copy to clipboard' => [ ['C00-c', 'C00-Insert'] , \©_to_clipboard ], 'Insert from clipboard' => [ ['C00-v', '00S-Insert'] , \&insert_from_clipboard ], ) ; #---------------------------------------------------------------------------------------------- sub copy_to_clipboard { my ($self) = @_ ; my @selected_elements = $self->get_selected_elements(1) ; return unless @selected_elements ; my %selected_elements = map { $_ => 1} @selected_elements ; my @connections = grep { exists $selected_elements{$_->{CONNECTED}} && exists $selected_elements{$_->{CONNECTEE}} } $self->get_connections_containing(@selected_elements) ; my $elements_and_connections = { ELEMENTS => \@selected_elements, CONNECTIONS => \@connections , }; $self->{CLIPBOARD} = Clone::clone($elements_and_connections) ; } ; #---------------------------------------------------------------------------------------------- sub insert_from_clipboard { my ($self, $x_offset, $y_offset) = @_ ; if(defined $self->{CLIPBOARD}{ELEMENTS} && @{$self->{CLIPBOARD}{ELEMENTS}}) { $self->create_undo_snapshot() ; $self->deselect_all_elements() ; unless(defined $x_offset) { my $min_x = min(map {$_->{X}} @{$self->{CLIPBOARD}{ELEMENTS}}) ; $x_offset = $min_x - $self->{MOUSE_X} ; } unless(defined $y_offset) { my $min_y = min(map {$_->{Y}} @{$self->{CLIPBOARD}{ELEMENTS}}) ; $y_offset = $min_y - $self->{MOUSE_Y} ; } my %new_group ; for my $element (@{$self->{CLIPBOARD}{ELEMENTS}}) { @$element{'X', 'Y'}= ($element->{X} - $x_offset, $element->{Y} - $y_offset) ; if(exists $element->{GROUP} && scalar(@{$element->{GROUP}}) > 0) { my $group = $element->{GROUP}[-1] ; unless(exists $new_group{$group}) { $new_group{$group} = {'GROUP_COLOR' => $self->get_group_color()} ; } pop @{$element->{GROUP}} ; push @{$element->{GROUP}}, $new_group{$group} ; } else { delete $element->{GROUP} ; } } my $clipboard = Clone::clone($self->{CLIPBOARD}) ; $self->add_elements_no_connection(@{$clipboard->{ELEMENTS}}) ; $self->add_connections(@{$clipboard->{CONNECTIONS}}) ; $self->update_display() ; } } ; App-Asciio-1.51.3/setup/actions/presentation.pl000444001750000144 340012544473514 21151 0ustar00nadimusers000000000000 #---------------------------------------------------------------------------------------------- register_action_handlers ( 'Load slides'=> ['C00-l', \&load_slides] , 'previous slide' => ['C00-Left', \&previous_slide], 'next slide' => ['C00-Right', \&next_slide], 'first slide' => ['C00-Up', \&first_slide], ) ; #---------------------------------------------------------------------------------------------- my ($slides, $current_slide) ; #---------------------------------------------------------------------------------------------- sub load_slides { my ($self, $file_name) = @_ ; # get file name for slides definitions $file_name = $self->get_file_name('open') unless defined $file_name ; if(defined $file_name && $file_name ne q{}) { # load slides $slides = do $file_name or die $@ ; $current_slide = 0 ; # run first slide $slides->[$current_slide]->($self) ; $self->update_display() ; } } #---------------------------------------------------------------------------------------------- sub first_slide { my ($self) = @_ ; if($slides) { $current_slide = 0 ; $slides->[$current_slide]->($self) ; $self->update_display() ; } } #---------------------------------------------------------------------------------------------- sub next_slide { my ($self) = @_ ; if($slides && $current_slide != $#$slides) { $current_slide++ ; $slides->[$current_slide]->($self) ; $self->update_display() ; } } #---------------------------------------------------------------------------------------------- sub previous_slide { my ($self) = @_ ; if($slides && $current_slide != 0) { $current_slide-- ; $slides->[$current_slide]->($self) ; $self->update_display() ; } } #---------------------------------------------------------------------------------------------- App-Asciio-1.51.3/setup/actions/context_menu_rulers.pl000444001750000144 457212544473514 22555 0ustar00nadimusers000000000000 #---------------------------------------------------------------------------------------------- register_action_handlers ( 'Add vertical ruler' => ['000-r', \&add_ruler, {TYPE => 'VERTICAL'}, \&rulers_context_menu], 'Add horizontal ruler' => ['0A0-r', \&add_ruler, {TYPE => 'HORIZONTAL'}], 'Remove rulers' => ['00S-R', \&remove_ruler], ) ; #---------------------------------------------------------------------------------------------- use Clone ; #---------------------------------------------------------------------------------------------- sub add_ruler { my ($self, $data_argument) = @_ ; $self->create_undo_snapshot() ; my $data ; if(! defined $data_argument) { $data = {TYPE => 'VERTICAL', POSITION => $self->{MOUSE_X}} } else { $data = Clone::clone$data_argument ; } if(! defined $data->{POSITION}) { if($data->{TYPE} eq 'VERTICAL') { $data->{POSITION} = $self->{MOUSE_X} ; } else { $data->{POSITION} = $self->{MOUSE_Y} ; } } $self->add_ruler_lines ({ COLOR => $self->{COLORS}{ruler_line}, NAME => 'from context menu', %{$data}, }) ; $self->update_display(); } #---------------------------------------------------------------------------------------------- sub remove_ruler { my ($self, $data) = @_ ; $data = {TYPE => 'VERTICAL', POSITION => $self->{MOUSE_X}} unless defined $data ; $self->create_undo_snapshot() ; $self->remove_ruler_lines($data) ; $self->update_display(); } #---------------------------------------------------------------------------------------------- sub rulers_context_menu { my ($self, $popup_x, $popup_y) = @_ ; my @context_menu_entries ; my ($x, $y) = $self->closest_character($popup_x, $popup_y) ; my $vertical = {TYPE => 'VERTICAL', POSITION => $x} ; my $horizontal = {TYPE => 'HORIZONTAL', POSITION => $y} ; if($self->exists_ruler_line($vertical)) { push @context_menu_entries, ["/Ruler/remove vertical ruler", \&remove_ruler, $vertical] ; } else { push @context_menu_entries, ["/Ruler/add vertical ruler", \&add_ruler, $vertical] ; } if($self->exists_ruler_line($horizontal)) { push @context_menu_entries, ["/Ruler/remove horizontal ruler", \&remove_ruler, $horizontal] ; } else { push @context_menu_entries, ["/Ruler/add horizontal ruler", \&add_ruler, $horizontal] ; } return(@context_menu_entries) ; } #---------------------------------------------------------------------------------------------- App-Asciio-1.51.3/setup/actions/context_menu_multi_wirl.pl000444001750000144 2441212544473514 23443 0ustar00nadimusers000000000000 #---------------------------------------------------------------------------------------------- register_action_handlers ( 'Append multi_wirl section' => ['000-s', \&append_section, undef, \&multi_wirl_context_menu], 'Prepend multi_wirl section' => ['0A0-s', \&prepend_section], 'Remove last section from multi_wirl' => ['000-q', \&remove_last_section_from_section_wirl_arrow], 'Remove first section from multi_wirl' => ['0A0-q', \&remove_first_section_from_section_wirl_arrow], 'Insert multi_wirl section' => ['00S-S', \&insert_wirl_arrow_section], ) ; #---------------------------------------------------------------------------------------------- sub insert_wirl_arrow_section { my ($self) = @_ ; my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements == 1 && 'App::Asciio::stripes::section_wirl_arrow' eq ref $selected_elements[0]) { my $element = $selected_elements[0] ; $self->create_undo_snapshot() ; my $x_offset = $self->{MOUSE_X} - $element->{X} ; my $y_offset = $self->{MOUSE_Y} - $element->{Y} ; $self->delete_connections_containing($element) ; $element->insert_section($x_offset, $y_offset) ; $self->connect_elements($element) ; $self->update_display() ; } } #---------------------------------------------------------------------------------------------- sub prepend_section { my ($self) = @_ ; my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements == 1 && 'App::Asciio::stripes::section_wirl_arrow' eq ref $selected_elements[0]) { my $element = $selected_elements[0] ; $self->create_undo_snapshot() ; $self->delete_connections_containing($element) ; my $x_offset = $self->{MOUSE_X} - $element->{X} ; my $y_offset = $self->{MOUSE_Y} - $element->{Y} ; $element->prepend_section($x_offset, $y_offset) ; $self->move_elements($x_offset, $y_offset, $element) ; $self->update_display() ; } } #---------------------------------------------------------------------------------------------- sub append_section { my ($self) = @_ ; my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements == 1 && 'App::Asciio::stripes::section_wirl_arrow' eq ref $selected_elements[0]) { my $element = $selected_elements[0] ; add_section_to_section_wirl_arrow ( $self, { ELEMENT => $element, X => $self->{MOUSE_X} - $element->{X}, Y => $self->{MOUSE_Y} - $element->{Y}, } ) ; } } #---------------------------------------------------------------------------------------------- sub add_section_to_section_wirl_arrow { my ($self, $data) = @_ ; $self->create_undo_snapshot() ; $self->delete_connections_containing($data->{ELEMENT}) ; $data->{ELEMENT}->append_section($data->{X}, $data->{Y}) ; $self->connect_elements($data->{ELEMENT}) ; $self->call_hook('CANONIZE_CONNECTIONS', $self->{CONNECTIONS}, $self->get_character_size()) ; $self->update_display() ; } #---------------------------------------------------------------------------------------------- sub remove_last_section_from_section_wirl_arrow { my ($self, $data) = @_ ; my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements == 1 && 'App::Asciio::stripes::section_wirl_arrow' eq ref $selected_elements[0]) { my $element = $selected_elements[0] ; $self->create_undo_snapshot() ; $self->delete_connections_containing($element) ; $element->remove_last_section() ; $self->connect_elements($element) ; $self->call_hook('CANONIZE_CONNECTIONS', $self->{CONNECTIONS}, $self->get_character_size()) ; $self->update_display() ; } } #---------------------------------------------------------------------------------------------- sub remove_first_section_from_section_wirl_arrow { my ($self, $data) = @_ ; my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements == 1 && 'App::Asciio::stripes::section_wirl_arrow' eq ref $selected_elements[0]) { my $element = $selected_elements[0] ; $self->create_undo_snapshot() ; $self->delete_connections_containing($element) ; my ($second_arrow_x_offset, $second_arrow_y_offset) = $element->remove_first_section() ; $self->move_elements($second_arrow_x_offset, $second_arrow_y_offset, $element) ; $self->update_display() ; } } #---------------------------------------------------------------------------------------------- sub multi_wirl_context_menu { my ($self, $popup_x, $popup_y) = @_ ; my @context_menu_entries ; my ($character_width, $character_height) = $self->get_character_size() ; my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements == 1 && 'App::Asciio::stripes::section_wirl_arrow' eq ref $selected_elements[0]) { my $element = $selected_elements[0] ; my ($x, $y) = $self->closest_character($popup_x - ($element->{X} * $character_width) , $popup_y - ($element->{Y} * $character_height)) ; push @context_menu_entries, [ '/append section', \&add_section_to_section_wirl_arrow, {ELEMENT => $selected_elements[0], X => $x, Y => $y,} ] ; if($element->is_connection_allowed('start')) { push @context_menu_entries, ["/Arrow connection/start doesn't connect", sub {$selected_elements[0]->allow_connection('start',0) ;}] ; } else { push @context_menu_entries, ["/Arrow connection/start connects", sub {$selected_elements[0]->allow_connection('start',1) ;}] ; } if($element->is_connection_allowed('end')) { push @context_menu_entries, ["/Arrow connection/end doesn't connect", sub {$selected_elements[0]->allow_connection('end',0) ;}] ; } else { push @context_menu_entries, ["/Arrow connection/end connects", sub {$selected_elements[0]->allow_connection('end',1) ;}] ; } push @context_menu_entries, [ $selected_elements[0]->is_autoconnect_enabled() ? '/disable autoconnection' : '/enable autoconnection', sub { $self->create_undo_snapshot() ; $selected_elements[0]->enable_autoconnect(! $selected_elements[0]->is_autoconnect_enabled()) ; $self->update_display() ; } ] ; push @context_menu_entries, [ $selected_elements[0]->are_diagonals_allowed() ? '/no diagonals' : '/allow diagonals', sub {$selected_elements[0]->allow_diagonals(! $selected_elements[0]->are_diagonals_allowed()) ;} ] ; push @context_menu_entries, [ '/Arrow type/dash', \&change_arrow_type, {ELEMENT => $selected_elements[0], TYPE => 'dash', X => $x, Y => $y,} ] , [ '/Arrow type/dot', \&change_arrow_type, {ELEMENT => $selected_elements[0], TYPE => 'dot', X => $x, Y => $y,} ], [ '/Arrow type/octo', \&change_arrow_type, {ELEMENT => $selected_elements[0], TYPE => 'octo',X => $x, Y => $y,} ], [ '/Arrow type/star', \&change_arrow_type, {ELEMENT => $selected_elements[0], TYPE => 'star', X => $x, Y => $y, } ] ; } return(@context_menu_entries) ; } #---------------------------------------------------------------------------------------------- sub arrow_connection { my ($self, $arguments) = @_ ; $arguments->{ELEMENT}->allow_connection($arguments->{WHICH}, $arguments->{CONNECT}) ; } #---------------------------------------------------------------------------------------------- my %arrow_types = ( dash => [ ['origin', '', '*', '', '', '', 1], ['up', '|', '|', '', '', '^', 1], ['down', '|', '|', '', '', 'v', 1], ['left', '-', '-', '', '', '<', 1], ['upleft', '|', '|', '.', '-', '<', 1], ['leftup', '-', '-', '\'', '|', '^', 1], ['downleft', '|', '|', '\'', '-', '<', 1], ['leftdown', '-', '-', '.', '|', 'v', 1], ['right', '-', '-','', '', '>', 1], ['upright', '|', '|', '.', '-', '>', 1], ['rightup', '-', '-', '\'', '|', '^', 1], ['downright', '|', '|', '\'', '-', '>', 1], ['rightdown', '-', '-', '.', '|', 'v', 1], ['45', '/', '/', '', '', '^', 1, ], ['135', '\\', '\\', '', '', 'v', 1, ], ['225', '/', '/', '', '', 'v', 1, ], ['315', '\\', '\\', '', '', '^', 1, ], ], dot => [ ['origin', '', '*', '', '', '', 1], ['up', '.', '.', '', '', '^', 1], ['down', '.', '.', '', '', 'v', 1], ['left', '.', '.', '', '', '<', 1], ['upleft', '.', '.', '.', '.', '<', 1], ['leftup', '.', '.', '\'', '.', '^', 1], ['downleft', '.', '.', '\'', '.', '<', 1], ['leftdown', '.', '.', '.', '.', 'v', 1], ['right', '.', '.','', '', '>', 1], ['upright', '.', '.', '.', '.', '>', 1], ['rightup', '.', '.', '\'', '.', '^', 1], ['downright', '.', '.', '\'', '.', '>', 1], ['rightdown', '.', '.', '.', '.', 'v', 1], ['45', '.', '.', '', '', '^', 1, ], ['135', '.', '.', '', '', 'v', 1, ], ['225', '.', '.', '', '', 'v', 1, ], ['315', '.', '.', '', '', '^', 1, ], ], star => [ ['origin', '', '*', '', '', '', 1], ['up', '*', '*', '', '', '^', 1], ['down', '*', '*', '', '', 'v', 1], ['left', '*', '*', '', '', '<', 1], ['upleft', '*', '*', '*', '*', '<', 1], ['leftup', '*', '*', '*', '*', '^', 1], ['downleft', '*', '*', '*', '*', '<', 1], ['leftdown', '*', '*', '*', '*', 'v', 1], ['right', '*', '*','', '', '>', 1], ['upright', '*', '*', '*', '*', '>', 1], ['rightup', '*', '*', '*', '*', '^', 1], ['downright', '*', '*', '*', '*', '>', 1], ['rightdown', '*', '*', '*', '*', 'v', 1], ['45', '*', '*', '', '', '^', 1, ], ['135', '*', '*', '', '', 'v', 1, ], ['225', '*', '*', '', '', 'v', 1, ], ['315', '*', '*', '', '', '^', 1, ], ], octo => [ ['origin', '', '#', '', '', '', 1], ['up', '#', '#', '', '', '^', 1], ['down', '#', '#', '', '', 'v', 1], ['left', '#', '#', '', '', '<', 1], ['upleft', '#', '#', '#', '#', '<', 1], ['leftup', '#', '#', '#', '#', '^', 1], ['downleft', '#', '#', '#', '#', '<', 1], ['leftdown', '#', '#', '#', '#', 'v', 1], ['right', '#', '#','', '', '>', 1], ['upright', '#', '#', '#', '#', '>', 1], ['rightup', '#', '#', '#', '#', '^', 1], ['downright', '#', '#', '#', '#', '>', 1], ['rightdown', '#', '#', '#', '#', 'v', 1], ['45', '#', '#', '', '', '^', 1, ], ['135', '#', '#', '', '', 'v', 1, ], ['225', '#', '#', '', '', 'v', 1, ], ['315', '#', '#', '', '', '^', 1, ], ], ) ; sub change_arrow_type { my ($self, $data) = @_ ; use Clone ; if(exists $arrow_types{$data->{TYPE}}) { $self->create_undo_snapshot() ; my $new_type = Clone::clone($arrow_types{$data->{TYPE}}) ; $data->{ELEMENT}->set_arrow_type($new_type) ; $self->update_display() ; } } #---------------------------------------------------------------------------------------------- App-Asciio-1.51.3/setup/actions/align.pl000444001750000144 1041512544473514 17554 0ustar00nadimusers000000000000 use List::Util qw(min max) ; #---------------------------------------------------------------------------------------------- register_action_handlers ( 'Align objects'=> { SHORTCUTS => '0A0-a', 'Align left' => ['000-l', \&align, 'left'], 'Align center' => ['000-c', \&align, 'center'], 'Align right' => ['000-r', \&align, 'right'], 'Align top' => ['000-t', \&align, 'top'], 'Align middle' => ['000-m', \&align, 'middle'], 'Align bottom' => ['000-b', \&align, 'bottom'], # spread vertically # spread horizontally # adjacent vert # adjacent hor # stack }, ) ; #---------------------------------------------------------------------------------------------- sub align { my ($self, $alignment) = @_ ; $self->create_undo_snapshot() ; my @elements_to_move = grep {my @connectors = $_->get_connector_points() ; @connectors == 0 } $self->get_selected_elements(1) ; for ($alignment) { $_ eq 'left' and do { my $left = min( map{$_->{X}} @elements_to_move) ; for my $element (@elements_to_move) { $self->move_elements($left - $element->{X},0, $element) ; } last ; } ; $_ eq 'center' and do { my $left = min( map{$_->{X}} @elements_to_move) ; my $right = max ( map { my ($w, $h) = $_->get_size() ; $_->{X} + $w ; } @elements_to_move ) ; my $center = int(($left + $right) / 2) ; # find element which center is closes to geometric center my $closest_element = undef ; my $closest_element_distance = 1_000_000 ; my $closest_center ; for my $element (@elements_to_move) { my ($w, $h) = $element->get_size() ; my $element_center = $element->{X} + int($w / 2) ; my $center_to_center_distance = abs($center - $element_center) ; if($center_to_center_distance <$closest_element_distance) { $closest_element = $element ; $closest_element_distance = $center_to_center_distance; $closest_center = $element_center ; } } for my $element (@elements_to_move) { next if $element == $closest_element ; my ($w, $h) = $element->get_size() ; my $element_center = $element->{X} + int($w / 2) ; $self->move_elements($closest_center - $element_center, 0, $element) ; } last ; } ; $_ eq 'right' and do { my $right = max ( map { my ($w, $h) = $_->get_size() ; $_->{X} + $w ; } @elements_to_move ) ; for my $element (@elements_to_move) { my ($w, $h) = $element->get_size() ; $self->move_elements($right - ($element->{X} + $w), 0, $element) ; } last ; } ; $_ eq 'top' and do { my $top = min( map{$_->{Y}} @elements_to_move) ; for my$element (@elements_to_move) { $self->move_elements(0, $top - $element->{Y}, $element) ; } last ; } ; $_ eq 'middle' and do { my $top = min( map{$_->{Y}} @elements_to_move) ; my $bottom = max ( map { my ($w, $h) = $_->get_size() ; $_->{Y} + $h ; } @elements_to_move ) ; my $center = int(($top + $bottom) / 2) ; # find element which center is closes to geometric center my $closest_element = undef ; my $closest_element_distance = 1_000_000 ; my $closest_center ; for my $element (@elements_to_move) { my ($w, $h) = $element->get_size() ; my $element_center = $element->{Y} + int($h / 2) ; my $center_to_center_distance = abs($center - $element_center) ; if($center_to_center_distance <$closest_element_distance) { $closest_element = $element ; $closest_element_distance = $center_to_center_distance; $closest_center = $element_center ; } } for my $element (@elements_to_move) { next if $element == $closest_element ; my ($w, $h) = $element->get_size() ; my $element_center = $element->{Y} + int($h / 2) ; $self->move_elements(0, $closest_center - $element_center, $element) ; } last ; } ; $_ eq 'bottom' and do { my $bottom = max ( map { my ($w, $h) = $_->get_size() ; $_->{Y} + $h ; } @elements_to_move ) ; for my $element (@elements_to_move) { my ($w, $h) = $element->get_size() ; $self->move_elements(0, $bottom - ($element->{Y} + $h), $element) ; } last ; } ; } $self->update_display() ; } App-Asciio-1.51.3/setup/actions/mouse.pl000444001750000144 1231312544473514 17611 0ustar00nadimusers000000000000 use List::MoreUtils qw(any minmax first_value) ; use Readonly ; use App::Asciio::stripes::section_wirl_arrow ; #---------------------------------------------------------------------------------------------- register_action_handlers ( 'Quick link' => ['C0S-button_press-1', \&quick_link] , #~ 'C00-button_release' => ['', ] , #~ 'C00-motion_notify' =>['', ] , ) ; #---------------------------------------------------------------------------------------------- Readonly my $PREFERED_DIRECTION => 'right-down' ; # or 'down-right' ; #---------------------------------------------------------------------------------------------- sub quick_link { my ($self, $event) = @_ ; $self->create_undo_snapshot() ; if($event->{BUTTON} == 1) { my ($x, $y) = @{$event->{COORDINATES}} ; my ($destination_element) = first_value {$self->is_over_element($_, $x, $y)} reverse @{$self->{ELEMENTS}} ; if($destination_element) { connect_to_destination_element($self, $destination_element, $x, $y) ; } else { # user clicked in void or un-linkable object no_destination_element($self, $x, $y) ; } } #~ if($event->type eq '2button-press') #~ { #~ } #~ if($event->button == 3) #~ { #~ } } #---------------------------------------------------------------------------------------------- sub no_destination_element { my ($self, $x, $y) = @_ ; my $new_box = $self->add_new_element_named('stencils/asciio/box', $x, $y) ; connect_to_destination_element($self, $new_box, $x, $y) ; } #---------------------------------------------------------------------------------------------- sub connect_to_destination_element { my ($self, $destination_element, $x, $y) = @_ ; my @destination_connections = grep {$_->{NAME} ne 'resize'} $destination_element->get_connection_points() ; if(@destination_connections) { my @selected_elements = grep {$_ != $destination_element} $self->get_selected_elements(1) ; my $destination_connection = $destination_connections[0] ; if(@selected_elements) { $self->deselect_all_elements() ; for my $element (@selected_elements) { # link $element to $destination_element my @source_connections = grep {$_->{NAME} ne 'resize'} $element->get_connection_points() ; if(@source_connections) { connect_from_box($self, $element, $source_connections[0], $destination_element, $destination_connection) ; } else { connect_from_arrow($self, $element, $destination_element, $destination_connection) ; } } $self->select_elements(1, @selected_elements) ; } else { $self->select_elements(1, $destination_element) ; } $self->update_display() ; # will also canonize the connections } } #---------------------------------------------------------------------------------------------- sub connect_from_box { my ($self, $element, $source_connection, $destination_element, $destination_connection) = @_ ; my $wirl_arrow = new App::Asciio::stripes::section_wirl_arrow ({ POINTS => [ [ ($destination_element->{X} + $destination_connection->{X}) - ($element->{X} + $source_connection->{X}), ($destination_element->{Y} + $destination_connection->{Y}) - ($element->{Y} + $source_connection->{Y}), $PREFERED_DIRECTION, ], ], DIRECTION => $PREFERED_DIRECTION, ALLOW_DIAGONAL_LINES => 0, EDITABLE => 1, RESIZABLE => 1, }) ; $self->add_element_at_no_connection ( $wirl_arrow, $element->{X} + $source_connection->{X}, $element->{Y} + $source_connection->{Y}, ) ; $self->add_connections ({ CONNECTED => $wirl_arrow, CONNECTOR => $wirl_arrow->get_named_connection('startsection_0'), CONNECTEE => $element, CONNECTION => $source_connection, }) ; $self->add_connections ({ CONNECTED => $wirl_arrow, CONNECTOR => $wirl_arrow->get_named_connection('endsection_0'), CONNECTEE => $destination_element, CONNECTION => $destination_connection, }) ; } #---------------------------------------------------------------------------------------------- sub connect_from_arrow { my ($self, $element, $destination_element, $destination_connection) = @_ ; my %source_connectors = map {$_->{NAME} => $_} grep {$_->{NAME} ne 'resize'} $element->get_connector_points() ; for(grep {$_->{CONNECTED} == $element } @{$self->{CONNECTIONS}}) { delete $source_connectors{$_->{CONNECTOR}{NAME}} ; } my ($unconnected_connector_name) = reverse sort keys %source_connectors ; if($unconnected_connector_name) { my $unconnected_connector = $source_connectors{$unconnected_connector_name} ; my ($x_offset, $y_offset) = $element->move_connector ( $unconnected_connector_name, ($destination_element->{X} + $destination_connection->{X}) - ($element->{X} + $unconnected_connector->{X}), ($destination_element->{Y} + $destination_connection->{Y}) - ($element->{Y} + $unconnected_connector->{Y}), ) ; $element->{X} += $x_offset ; $element->{Y} += $y_offset ; my $new_connection = { CONNECTED => $element, CONNECTOR =>$unconnected_connector, CONNECTEE => $destination_element, CONNECTION => $destination_connection, } ; $self->add_connections($new_connection) ; } } #---------------------------------------------------------------------------------------------- App-Asciio-1.51.3/setup/actions/new_elements.pl000444001750000144 213612544473514 21130 0ustar00nadimusers000000000000 #---------------------------------------------------------------------------------------------- register_action_handlers ( 'Add box' => ['000-b', \&add_element, ['stencils/asciio/box', 0]], 'Add shrink box' => ['00S-B', \&add_element, ['stencils/asciio/shrink_box', 1]], 'Add text' => ['000-t', \&add_element, ['stencils/asciio/text', 0]], 'Add if' => ['000-i', \&add_element, ['stencils/asciio/boxes/if', 1]], 'Add process' => ['000-p', \&add_element, ['stencils/asciio/boxes/process', 1]], 'Add arrow' => ['000-a', \&add_element, ['stencils/asciio/wirl_arrow', 0]], 'Add angled arrow' => ['00S-A', \&add_element, ['stencils/asciio/angled_arrow', 0]], ) ; #---------------------------------------------------------------------------------------------- sub add_element { my ($self, $name_and_edit) = @_ ; $self->create_undo_snapshot() ; $self->deselect_all_elements() ; my ($name, $edit) = @{$name_and_edit} ; my $element = $self->add_new_element_named($name, $self->{MOUSE_X}, $self->{MOUSE_Y}) ; $element->edit($self) if $edit; $self->select_elements(1, $element); $self->update_display() ; } ; App-Asciio-1.51.3/setup/actions/file.pl000444001750000144 714512544473514 17367 0ustar00nadimusers000000000000 use File::Basename ; #---------------------------------------------------------------------------------------------- register_action_handlers ( 'Open' => ['C00-o', \&open], 'Save' => ['C00-s', \&save, undef], 'SaveAs' => ['C0S-S', \&save, 'as'], 'Insert' => ['C00-i', \&insert], ) ; #---------------------------------------------------------------------------------------------- sub save { my ($self, $as, $type, $file_name) = @_ ; unless(defined $file_name) { if((! defined $as) && $self->get_title()) { $file_name = $self->get_title() ; } else { $file_name = $self->get_file_name('save') ; if(defined $file_name && $file_name ne q[]) { if(-e $file_name) { my $override = $self->display_yes_no_cancel_dialog ( "Override file!", "File '$file_name' exists!\nOverride file?" ) ; $file_name = undef unless $override eq 'yes' ; } } } } if(defined $file_name && $file_name ne q[]) { my ($base_name, $path, $extension) = File::Basename::fileparse($file_name, ('\..*')) ; $extension =~ s/^\.// ; $type = defined $type ? $type : $extension ne q{} ? $extension : 'asciio_internal_format' ; my $elements_to_save = Clone::clone($self->{ELEMENTS}) ; for my $element (@{$elements_to_save}) { delete $element->{NAME} ; } my $new_title ; eval { $new_title = $self->save_with_type($elements_to_save, $type, $file_name) ; } ; if($@) { $self->display_message_modal("Can't save file '$file_name':\n$@\n") ; $file_name = undef ; } else { if(defined $new_title) { $self->set_title($new_title) ; $self->set_modified_state(0) ; } } } return $file_name ; } ; #---------------------------------------------------------------------------------------------- sub open { my ($self, $file_name) = @_ ; my $user_answer = '' ; if($self->get_modified_state()) { $user_answer = $self->display_yes_no_cancel_dialog('asciio', 'Diagram modified. Save it?') ; if($user_answer eq 'yes') { my $file_name = $self->get_file_name('save') ; my ($base_name, $path, $extension) = File::Basename::fileparse($file_name, ('\..*')) ; $extension =~ s/^\.// ; my $type = $extension ne q{} ? $extension : 'asciio_internal_format' ; $self->save_with_type(undef, $type, $file_name) if(defined $file_name && $file_name ne q[]) ; } } if($user_answer ne 'cancel') { $file_name ||= $self->get_file_name('open') ; if(defined $file_name && $file_name ne q[]) { my $title = $self->load_file($file_name) ; my ($base_name, $path, $extension) = File::Basename::fileparse($file_name, ('\..*')) ; $extension =~ s/^\.// ; my $type = $extension ne q{} ? $extension : 'asciio_internal_format' ; $self->set_title($title) if defined $title; $self->set_modified_state(0) ; } } } ; #---------------------------------------------------------------------------------------------- sub insert { my ($self, $x, $y, $file_name) = @_ ; $file_name ||= $self->get_file_name('open') ; if(defined $file_name && $file_name ne q[]) { my $asciio = new App::Asciio() ; use Module::Util qw(find_installed) ; use File::Basename ; my ($basename, $path, $ext) = File::Basename::fileparse(find_installed('App::Asciio'), ('\..*')) ; my $setup_path = $path . $basename . '/setup/' ; $asciio->setup([$setup_path . 'setup.ini', ] ) ; $asciio->load_file($file_name) ; $asciio->run_actions_by_name('Select all elements', 'Copy to clipboard') ; use Clone ; $self->{CLIPBOARD} = Clone::clone($asciio->{CLIPBOARD}) ; $self->run_actions_by_name(['Insert from clipboard', $x, $y]) ; } } ; App-Asciio-1.51.3/setup/actions/unsorted.pl000444001750000144 3145012544473514 20327 0ustar00nadimusers000000000000 use strict ; use warnings ; #---------------------------------------------------------------------------------------------- register_action_handlers ( 'Create multiple box elements from a text description' => ['C00-m', \&insert_multiple_boxes_from_text_description, 1], 'Create multiple text elements from a text description' => ['C0S-M', \&insert_multiple_boxes_from_text_description, 0], 'Flip transparent element background' => ['C00-t', \&transparent_elements], 'Flip grid display' => ['000-g', \&flip_grid_display], 'Flip color scheme' => ['CA0-c', \&flip_color_scheme], 'Undo' => ['C00-z', \&undo], 'Display undo stack statistics' => ['C0S-Z', \&display_undo_stack_statistics], 'Redo' => ['C00-y', \&redo], 'Display keyboard mapping' => ['000-k', \&display_keyboard_mapping], 'Display commands' => ['C00-k', \&display_commands], 'Display action files' => ['C0S-K', \&display_action_files], 'Zoom in' => ['000-KP_Add', \&zoom, 1], 'Zoom out' => ['000-minus', \&zoom, -1], 'Zoom in' => ['000-plus', \&zoom, 1], 'Zoom out' => ['000-KP_Subtract', \&zoom, -1], 'Help' => ['000-F1', \&display_help], 'External command output in a box' => ['000-x', \&external_command_output, 1], 'External command output in a box no frame' => ['C00-x', \&external_command_output, 0], ) ; #---------------------------------------------------------------------------------------------- sub display_help { my ($self) = @_ ; $self->display_message_modal(<get_font() ; $self->set_font($family, $size + $direction) ; } #---------------------------------------------------------------------------------------------- sub flip_color_scheme { my ($self) = @_ ; $self->{COLOR_SCHEME} = 'system' unless exists $self->{COLOR_SCHEME} ; if($self->{COLOR_SCHEME} eq 'system') { $self->flush_color_cache() ; $self->{COLOR_SCHEME} = 'linux' ; $self->{COLORS} = { background => [10, 10, 10], grid => [30, 30, 30], ruler_line => [25, 60, 80], selected_element_background => [25, 40, 50], element_background => [25, 25, 25], element_foreground => [150, 150, 150] , selection_rectangle => [110, 0, 110], test => [0, 255, 255], group_colors => [ [[0x41, 0x32, 0x23], [0x2B, 0x21, 0x17]], [[0x21, 0x3C, 0x23], [0x15, 0x27, 0x17]], [[0x23, 0x32, 0x3C], [0x18, 0x22, 0x29]], [[0x10, 0x44, 0x44], [0x0A, 0x2C, 0x2C]], [[0x50, 0x28, 0x20], [0x2E, 0x17, 0x13]], ], connection => [140, 65, 20], connection_point => [130, 100, 50], connector_point => [20, 100, 155], new_connection => [180, 0, 0], extra_point => [150, 110, 50], } ; $self->update_display() ; } else { $self->flush_color_cache() ; $self->{COLOR_SCHEME} = 'system' ; $self->{COLORS} = { background => [255, 255, 255], grid => [229, 235, 255], ruler_line => [85, 155, 225], selected_element_background => [180, 244, 255], element_background => [251, 251, 254], element_foreground => [0, 0, 0] , selection_rectangle => [255, 0, 255], test => [0, 255, 255], group_colors => [ [[250, 221, 190], [250, 245, 239]], [[182, 250, 182], [241, 250, 241]], [[185, 219, 250], [244, 247, 250]], [[137, 250, 250], [235, 250, 250]], [[198, 229, 198], [239, 243, 239]], ], connection => 'Chocolate', connection_point => [230, 198, 133], connector_point => 'DodgerBlue', new_connection => 'red' , extra_point => [230, 198, 133], } ; $self->update_display() ; } } #---------------------------------------------------------------------------------------------- sub display_keyboard_mapping { my ($self) = @_ ; #~ print Data::TreeDumper::DumpTree $self->{ACTIONS_BY_NAME}, 'ACTIONS_BY_NAME:'; my $keyboard_mapping = get_keyboard_mapping($self->{ACTIONS_BY_NAME}) ; #~ print Data::TreeDumper::DumpTree $keyboard_mapping , 'Keyboard mapping:'; $self->show_dump_window ( $keyboard_mapping , 'Keyboard mapping:', DISPLAY_ADDRESS => 0, ) } sub get_keyboard_mapping { my ($actions, $list) = @_ ; $list ||= [] ; my $keyboard_mapping ; for my $action (keys %{$actions}) { if('ARRAY' eq ref $actions->{$action}) { my $shortcut = ref $actions->{$action}[0] eq '' ? $actions->{$action}[0] : '[' . join('/', @{$actions->{$action}[0]}) . ']'; $keyboard_mapping->{$shortcut . ' => ' . $action} = {FILE=> $actions->{$action}[6]} ; } elsif('HASH' eq ref $actions->{$action}) { my $sub_keyboard_mapping = get_keyboard_mapping($actions->{$action}) ; for my $shortcut (keys %{$sub_keyboard_mapping}) { my $start_shortcut = '[' . join('/', $actions->{$action}{SHORTCUTS}) . '] + '; $keyboard_mapping->{$start_shortcut . $shortcut} = $sub_keyboard_mapping->{$shortcut} ; } } else { #~ die "unknown type while running 'dump_keyboard_mapping'\n" ; } } return($keyboard_mapping) ; } #---------------------------------------------------------------------------------------------- sub display_commands { my ($self) = @_ ; #~ print Data::TreeDumper::DumpTree $self->{ACTIONS_BY_NAME}, 'ACTIONS_BY_NAME:'; my $commands = get_commands($self->{ACTIONS_BY_NAME}) ; $self->show_dump_window ( $commands, 'commands:', DISPLAY_ADDRESS => 0, ) } sub get_commands { my ($actions, $list) = @_ ; $list ||= [] ; my $commands ; for my $action (keys %{$actions}) { if('ARRAY' eq ref $actions->{$action}) { my $shortcut = ref $actions->{$action}[0] eq '' ? $actions->{$action}[0] : '[' . join('/', @{$actions->{$action}[0]}) . ']'; $commands->{$action . " [$shortcut]"} = {FILE=> $actions->{$action}[6]} ; } elsif('HASH' eq ref $actions->{$action}) { my $sub_commands = get_commands($actions->{$action}) ; for my $shortcut (keys %{$sub_commands}) { my ($name, $shortcut_text) = $shortcut =~ /([^\[]*)(.*)/ ; my $start_shortcut = '[' . join('/', $actions->{$action}{SHORTCUTS}) . '] + '; $commands->{$name . $start_shortcut . $shortcut_text} = $sub_commands->{$shortcut} ; } } else { #~ die "unknown type while running 'dump_keyboard_mapping'\n" ; } } return($commands) ; } #---------------------------------------------------------------------------------------------- sub display_action_files { my ($self) = @_ ; my $actions_per_file = {} ; generate_keyboard_mapping_text_dump($self->{ACTIONS_BY_NAME}, $actions_per_file) ; #~ print Data::TreeDumper::DumpTree #~ $actions_per_file, #~ 'Action files:', #~ DISPLAY_ADDRESS => 0, #~ GLYPHS => [' ', ' ', ' ', ' '], #~ NO_NO_ELEMENTS => 1, #~ FILTER => \&filter_keyboard_mapping ; $self->show_dump_window ( $actions_per_file, 'Action files:', DISPLAY_ADDRESS => 0, GLYPHS => [' ', ' ', ' ', ' '], NO_NO_ELEMENTS => 1, FILTER => \&filter_keyboard_mapping ) ; } sub filter_keyboard_mapping { my $s = shift ; if('HASH' eq ref $s) { my (%hash, @keys) ; for my $entry (sort keys %{$s}) { if('ARRAY' eq ref $s->{$entry}) { my $shortcuts = $s->{$entry}[0] ; $shortcuts = join(' ', @{$shortcuts}) if('ARRAY' eq ref $shortcuts) ; my $key_name = "$entry [$shortcuts]" ; $hash{$key_name} = [] ; push @keys, $key_name ; } else { $hash{$entry} = $s->{$entry} ; push @keys, $entry ; } } return('HASH', \%hash, @keys) ; } return(Data::TreeDumper::DefaultNodesToDisplay($s)) ; } sub generate_keyboard_mapping_text_dump { my ($key_mapping, $actions_per_file) = @_ ; die "Need argument!" unless defined $actions_per_file ; for my $action (keys %{$key_mapping}) { if('ARRAY' eq ref $key_mapping->{$action}) { $actions_per_file->{$key_mapping->{$action}[6]}{$action} = $key_mapping->{$action} ; } elsif('HASH' eq ref $key_mapping->{$action}) { my $sub_actions = {} ; { local $key_mapping->{$action}{GROUP_NAME} = undef ; local $key_mapping->{$action}{ORIGIN} = undef ; local $key_mapping->{$action}{SHORTCUTS} = undef ; generate_keyboard_mapping_text_dump($key_mapping->{$action}, $sub_actions) ; } #~ print Data::TreeDumper::DumpTree $key_mapping->{$action} ; #~ print Data::TreeDumper::DumpTree $sub_actions ; my $shortcuts = $key_mapping->{$action}{SHORTCUTS} ; $shortcuts = join(' ', @{$key_mapping->{$action}{SHORTCUTS}}) if('ARRAY' eq ref $key_mapping->{$action}{SHORTCUTS}) ; $actions_per_file->{$key_mapping->{$action}{ORIGIN}}{"group: $action [$shortcuts]"} = $sub_actions->{$key_mapping->{$action}{ORIGIN}} ; } else { #~ print Data::TreeDumper::DumpTree $key_mapping->{$action}, $action ; #~ die "unknown type while running 'dump_keyboard_mapping'\n" ; } } } #---------------------------------------------------------------------------------------------- sub undo { my ($self) = @_ ; $self->undo(1) ; } #---------------------------------------------------------------------------------------------- sub redo { my ($self) = @_ ; $self->redo(1) ; } #---------------------------------------------------------------------------------------------- sub display_undo_stack_statistics { my ($self) = @_ ; my $statistics = { DO_STACK_POINTER => $self->{DO_STACK_POINTER} } ; my $total_size = 0 ; for my $stack_element (@{$self->{DO_STACK}}) { push @{$statistics->{ELEMENT_SIZE}}, length($stack_element) ; $total_size += length($stack_element) ; } $statistics->{TOTAL_SIZE} = $total_size ; $self->show_dump_window($statistics, 'Undo stack statistics:') ; } #---------------------------------------------------------------------------------------------- sub insert_multiple_boxes_from_text_description { my ($self, $boxed) = @_ ; my $text = $self->display_edit_dialog('multiple texts from input', "\ntext\ntext\ntext\ntext" ) ; if(defined $text && $text ne '') { $self->create_undo_snapshot() ; my ($current_x, $current_y) = ($self->{MOUSE_X}, $self->{MOUSE_Y}) ; my ($separator) = split("\n", $text) ; $text =~ s/$separator\n// ; my @new_elements ; for my $element_text (split("$separator\n", $text)) { chomp $element_text ; my $new_element = new App::Asciio::stripes::editable_box2 ({ TITLE => '', TEXT_ONLY => $element_text, EDITABLE => 1, RESIZABLE => 1, }) ; if(! $boxed) { my $box_type = $new_element->get_box_type() ; for my $box_element (@{$box_type}) { $box_element->[0] = 0 ; } $new_element->set_box_type($box_type) ; $new_element->shrink() ; } @$new_element{'X', 'Y'} = ($current_x, $current_y) ; $current_x += $self->{COPY_OFFSET_X} ; $current_y += $self->{COPY_OFFSET_Y} ; push @new_elements , $new_element ; } $self->deselect_all_elements() ; $self->add_elements(@new_elements) ; $self->select_elements(1, @new_elements) ; $self->update_display() ; } } #---------------------------------------------------------------------------------------------- sub flip_grid_display { my ($self) = @_ ; $self->{DISPLAY_GRID} ^=1 ; $self->update_display() ; } #---------------------------------------------------------------------------------------------- sub transparent_elements { my ($self) = @_ ; $self->{OPAQUE_ELEMENTS} ^=1 ; $self->update_display() ; } #---------------------------------------------------------------------------------------------- sub external_command_output { my ($self, $in_box) = @_ ; $self->create_undo_snapshot() ; my $command = $self->display_edit_dialog('Enter command', '') ; if(defined $command && $command ne '') { (my $command_stderr_redirected = $command) =~ s/$/ 2>&1/gsm ; my $output = `$command_stderr_redirected` ; if($?) { $output = '' unless defined $output ; $output = "Can't execute '$command':\noutput:\n$output\nerror:\n$! [$?]" ; $in_box++ ; } my @box ; unless($in_box) { push @box, BOX_TYPE => [ [0, 'top', '.', '-', '.', 1, ], [0, 'title separator', '|', '-', '|', 1, ], [0, 'body separator', '| ', '|', ' |', 1, ], [0, 'bottom', '\'', '-', '\'', 1, ], ] ; } use App::Asciio::stripes::editable_box2 ; my $new_element = new App::Asciio::stripes::editable_box2 ({ TEXT_ONLY => $output, TITLE => '', EDITABLE => 1, RESIZABLE => 1, @box }) ; $self->add_element_at($new_element, $self->{MOUSE_X}, $self->{MOUSE_Y}) ; $self->update_display() ; } } App-Asciio-1.51.3/setup/actions/colors.pl000444001750000144 313512544473514 17744 0ustar00nadimusers000000000000 #---------------------------------------------------------------------------------------------- register_action_handlers ( 'Change elements background color' => ['000-c', \&change_elements_colors, 0], 'Change elements foreground color' => ['00S-C', \&change_elements_colors, 1], 'Change AsciiO background color' => ['0A0-c', \&change_asciio_background_color], 'Change grid color' => ['0AS-C', \&change_grid_color], ) ; #---------------------------------------------------------------------------------------------- sub change_elements_colors { my ($self, $is_background) = @_ ; my ($color) = $self->get_color_from_user([0, 0, 0]) ; $self->create_undo_snapshot() ; for my $element($self->get_selected_elements(1)) { $is_background ? $element->set_background_color($color) : $element->set_foreground_color($color) ; } $self->update_display() ; } #---------------------------------------------------------------------------------------------- sub change_asciio_background_color { my ($self) = @_ ; my ($color) = $self->get_color_from_user([0, 0, 0]) ; $self->create_undo_snapshot() ; $self->flush_color_cache() ; $self->{COLORS}{background} = $color ; $self->update_display() ; } #---------------------------------------------------------------------------------------------- sub change_grid_color { my ($self) = @_ ; my ($color) = $self->get_color_from_user([0, 0, 0]) ; $self->create_undo_snapshot() ; $self->flush_color_cache() ; $self->{COLORS}{grid} = $color ; $self->update_display() ; } #---------------------------------------------------------------------------------------------- App-Asciio-1.51.3/setup/actions/context_menu_box.pl000444001750000144 1055612544473514 22050 0ustar00nadimusers000000000000 #---------------------------------------------------------------------------------------------- register_action_handlers ( 'box_context_menu' => ['box_context_menu', undef, undef, \&box_context_menu], ) ; #---------------------------------------------------------------------------------------------- use Readonly ; Readonly my $TOP => 0 ; Readonly my $TITLE_SEPARATOR => 1 ; Readonly my $BODY_SEPARATOR => 2 ; Readonly my $BOTTOM => 3; Readonly my $DISPLAY => 0 ; Readonly my $NAME => 1 ; Readonly my $LEFT => 2 ; Readonly my $BODY => 3 ; Readonly my $RIGHT => 4 ; my %box_types = ( dash => [ [1, 'top', '.', '-', '.', 1, ], [0, 'title separator', '|', '-', '|', 1, ], [1, 'body separator', '| ', '|', ' |', 1, ], [1, 'bottom', '\'', '-', '\'', 1, ], ], dot => [ [1, 'top', '.', '.', '.', 1, ], [0, 'title separator', '.', '.', '.', 1, ], [1, 'body separator', '. ', '.', ' .', 1, ], [1, 'bottom', '.', '.', '.', 1, ], ], star => [ [1, 'top', '*', '*', '*', 1, ], [0, 'title separator', '*', '*', '*', 1, ], [1, 'body separator', '* ', '*', ' *', 1, ], [1, 'bottom', '*', '*', '*', 1, ], ], ) ; #---------------------------------------------------------------------------------------------- sub box_context_menu { my ($self, $popup_x, $popup_y) = @_ ; my @context_menu_entries ; my ($character_width, $character_height) = $self->get_character_size() ; my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements == 1 && 'App::Asciio::stripes::editable_box2' eq ref $selected_elements[0]) { my $element = $selected_elements[0] ; my ($x, $y) = $self->closest_character($popup_x - ($element->{X} * $character_width) , $popup_y - ($element->{Y} * $character_height)) ; push @context_menu_entries, [ '/Rotate text', sub {$element->rotate_text() ;}, ] ; push @context_menu_entries, [ '/box selected element', \&box_selected_element, { ELEMENT => $element}, ] ; push @context_menu_entries, [ '/Box type/dash', \&change_box_type, { ELEMENT => $element, TYPE => 'dash', } ], [ '/Box type/dot', \&change_box_type, { ELEMENT => $element, TYPE => 'dot', } ], [ '/Box type/star', \&change_box_type, { ELEMENT => $element, TYPE => 'star', } ] ; push @context_menu_entries, [ $element->is_autoconnect_enabled() ? '/disable autoconnection' : '/enable autoconnection', sub { $self->create_undo_snapshot() ; $element->enable_autoconnect(! $element->is_autoconnect_enabled()) ; $self->update_display() ; } ] ; if($element->is_border_connection_allowed()) { push @context_menu_entries, ["/Disable border connection", sub {$element->allow_border_connection(0) ;}] ; } else { push @context_menu_entries, ["/Enable border connection", sub {$element->allow_border_connection(1) ;}] ; } if($element->is_auto_shrink()) { push @context_menu_entries, ["/Disable auto shrink", sub {$element->flip_auto_shrink() ;}] ; } else { push @context_menu_entries, ["/Enable auto shrink", sub {$element->shrink() ; $element->flip_auto_shrink() ; }] ; } } return(@context_menu_entries) ; } #---------------------------------------------------------------------------------------------- sub change_box_type { my ($self, $data) = @_ ; use Clone ; if(exists $box_types{$data->{TYPE}}) { $self->create_undo_snapshot() ; my $element_type = $data->{ELEMENT}->get_box_type() ; my $new_type = Clone::clone($box_types{$data->{TYPE}}) ; for (my $frame_element_index = 0 ; $frame_element_index < @{$new_type} ; $frame_element_index++) { $new_type->[$frame_element_index][$DISPLAY] = $element_type->[$frame_element_index][$DISPLAY] } $data->{ELEMENT}->set_box_type($new_type) ; $self->update_display() ; } } #---------------------------------------------------------------------------------------------- sub box_selected_element { my ($self, $data) = @_ ; $self->create_undo_snapshot() ; my $element_type = $data->{ELEMENT}->get_box_type() ; my ($title, $text) = $data->{ELEMENT}->get_text() ; for (0 .. $#$element_type) { next if $_ == $TITLE_SEPARATOR && $title eq '' ; $element_type->[$_][$DISPLAY] = 1 ; } $data->{ELEMENT}->set_box_type($element_type) ; $self->update_display() ; } #---------------------------------------------------------------------------------------------- App-Asciio-1.51.3/setup/actions/debug.pl000444001750000144 301212544473514 17523 0ustar00nadimusers000000000000 use List::Util qw(min max sum) ; #---------------------------------------------------------------------------------------------- register_action_handlers ( 'Dump self' => ['CA0-d', \&dump_self], 'Dump all elements' => ['C00-d', \&dump_all_elements], 'Dump selected elements'=> ['C0S-D' , \&dump_selected_elements], 'Test' => ['0A0-t', \&test], ) ; #---------------------------------------------------------------------------------------------- sub dump_self { my ($self) = @_ ; my $size = sum(map { length } @{$self->{DO_STACK}}) || 0 ; local $self->{DO_STACK} = scalar(@{$self->{DO_STACK}}) . " [$size]"; #~ print Data::TreeDumper::DumpTree $self ; $self->show_dump_window($self, 'asciio') ; } #---------------------------------------------------------------------------------------------- sub dump_selected_elements { my ($self) = @_ ; #~ print Data::TreeDumper::DumpTree [$self->get_selected_elements(1)] ; $self->show_dump_window([$self->get_selected_elements(1)], 'asciio selected elements') ; } #---------------------------------------------------------------------------------------------- sub dump_all_elements { my ($self) = @_ ; #~ print Data::TreeDumper::DumpTree $self->{ELEMENTS} ; $self->show_dump_window($self->{ELEMENTS}, 'asciio elements') ; } #---------------------------------------------------------------------------------------------- sub test { my ($self) = @_ ; $self->create_undo_snapshot() ; $self->run_actions_by_name(['Insert', 0, 0, 'insert_error.asciio']) ; $self->update_display() ; } App-Asciio-1.51.3/setup/asciio_object000755001750000144 012544473514 17104 5ustar00nadimusers000000000000App-Asciio-1.51.3/setup/asciio_object/basic.pl000444001750000144 255512544473514 20666 0ustar00nadimusers000000000000FONT_FAMILY => 'Monospace', FONT_SIZE => '14', TAB_AS_SPACES => ' ', DISPLAY_GRID => 1, COPY_OFFSET_X => 4, COPY_OFFSET_Y => 4, COLORS => { background => [255, 255, 255], grid => [229, 235, 255], ruler_line => [85, 155, 225], selected_element_background => [180, 244, 255], element_background => [251, 251, 254], element_foreground => [0, 0, 0] , selection_rectangle => [255, 0, 255], test => [0, 255, 255], group_colors => [ [[250, 221, 190], [250, 245, 239]], [[182, 250, 182], [241, 250, 241]], [[185, 219, 250], [244, 247, 250]], [[137, 250, 250], [235, 250, 250]], [[198, 229, 198], [239, 243, 239]], ], connection => 'Chocolate', connection_point => [230, 198, 133], connector_point => 'DodgerBlue', new_connection => 'red' , extra_point => [230, 198, 133], }, RULER_LINES => [ { TYPE => 'VERTICAL', COLOR => [220, 200, 200], POSITION => 80, NAME => 'RIGHT_80', }, { TYPE => 'VERTICAL', COLOR => [220, 200, 200], POSITION => 120, NAME => 'RIGHT_120', }, { TYPE => 'HORIZONTAL', COLOR => [220, 200, 200], POSITION => 50, NAME => 'BOTTOM_50', }, ], WORK_DIRECTORY => '.asciio_work_dir', CREATE_BACKUP => 1, DISPLAY_SETUP_INFORMATION => 0, MIDDLE_BUTTON_SELECTION_FILTER => sub { ref $_[0] ne 'App::Asciio::stripes::section_wirl_arrow' && ref $_[0] ne 'App::Asciio::stripes::angled_arrow' }, App-Asciio-1.51.3/setup/import_export000755001750000144 012544473514 17222 5ustar00nadimusers000000000000App-Asciio-1.51.3/setup/import_export/perl.pl000444001750000144 1035112544473514 20676 0ustar00nadimusers000000000000 #---------------------------------------------------------------------------------------------------------------------------- use File::Slurp ; use Data::Dumper ; use List::Util qw(max); use File::Basename ; #~ use Compress::LZF ':compress'; use Compress::Bzip2 qw(:all :utilities :gzip); use MIME::Base64 (); my $BASE64_HEADER = (' ' x 120) . '#asciio' ; my $BASE64_HEADER_SIZE = length($BASE64_HEADER) ; #---------------------------------------------------------------------------------------------------------------------------- register_import_export_handlers ( pod => { IMPORT => \&import_pod, EXPORT => \&export_pod, }, pl => { IMPORT => \&import_pod, EXPORT => \&export_pod, }, pm => { IMPORT => \&import_pod, EXPORT => \&export_pod, }, ) ; #---------------------------------------------------------------------------------------------------------------------------- sub import_pod { my ($self, $file) = @_ ; my ($base_name, $path, $extension) = File::Basename::fileparse($file, ('\..*')) ; my $file_name = $base_name . $extension ; my ($base64_data, $header, $footer) = get_base64_data($file_name) ; my $decoded_base64 = MIME::Base64::decode($base64_data); my $self_to_resurect = decompress($decoded_base64) ; my $VAR1 ; my $resurected_self = eval $self_to_resurect ; die $@ if $@ ; return($resurected_self, $file, {HEADER => $header, FOOTER => $footer}) ; } sub get_base64_data { =pod find all asciio sections select one section extract section remove diagram and padding regenerate base 64 string =cut my ($file_name) = @_ ; my ($header, $footer) = ('', '') ; eval "use Pod::Select ; use Pod::Text;" ; die $@ if $@ ; open INPUT, '<', $file_name or die "get_base64_data: Can't open '$file_name'!\n" ; open my $out, '>', \my $all_pod or die "Can't redirect to scalar output: $!\n"; my $parser = new Pod::Select(); $parser->parse_from_filehandle(\*INPUT, $out); $all_pod .= '=cut' ; #add the =cut taken away by above parsing my @asciio_pods ; while($all_pod =~ /(^=.*?(?=\n=))/smg) { my $section = $1 ; if($section =~ s/^=for asciio\s*//i) { push @asciio_pods, "=for asciio $section" ; last ; } } #todo: handle files without asciio section #todo: handle files with multiple asciio sections my $asciio_section = $asciio_pods[0] ; my @asciio_lines = split "\n", $asciio_section ; my $asciio_header = shift @asciio_lines ; #~ use Data::TreeDumper ; #~ print DumpTree \@asciio_lines, 'asciio_lines' ; my $whole_file = read_file($file_name) ; if($whole_file =~ /(.*)$asciio_header.*?(\n=.*)/sm) { ($header, $footer) = ($1, $2) ; } else { die "get_base64_data: Can't find the text we just extracted!" ; } my ($for, $asciio, $width, $name) = split ' ', $asciio_header ; my $base64 = '' ; for my $asciio_line (@asciio_lines) { substr($asciio_line, 0, $width + $BASE64_HEADER_SIZE + 1, '') ; # strip to base64 $base64 .= $asciio_line . "\n" ; } return ($base64, $header, $footer) ; } #---------------------------------------------------------------------------------------------------------------------------- sub export_pod { my ($self, $elements_to_save, $file, $data) = @_ ; my ($base_name, $path, $extension) = File::Basename::fileparse($file, ('\..*')) ; my $file_name = $base_name . $extension ; my @ascii_representation = $self->transform_elements_to_ascii_array() ; my $longest_line = max( map{length} @ascii_representation) ; my $compressed_self = compress($self->serialize_self() . '$VAR1 ;') ; my $base64 =MIME::Base64::encode($compressed_self, '') ; my $base64_chunk_size = int((length($base64) / @ascii_representation) + 1) ; if($self->{CREATE_BACKUP} && -e $file) { use File::Copy; copy($file,"$file.bak") or die "export_pod: Copy failed while making backup copy: $!"; } open POD, ">:encoding(utf8)", $file_name or die "export_pod: can't open file '$file_name'!\n"; print POD $data->{HEADER} || '' ; print POD "=for asciio $longest_line $base_name\n\n" ; for my $diagram_line (@ascii_representation) { my $padding = ' ' x ($longest_line - length($diagram_line)) ; my $base64_chunk = substr($base64, 0, $base64_chunk_size, '') || '' ; print POD ' ' , $diagram_line, $padding, $BASE64_HEADER, $base64_chunk, "\n" } print POD $data->{FOOTER} || "\n=cut\n\n"; close POD ; return $file ; } App-Asciio-1.51.3/setup/import_export/ascii.pl000444001750000144 103612544473514 21004 0ustar00nadimusers000000000000 register_import_export_handlers ( txt => { IMPORT => undef , EXPORT => \&export_ascii, }, ) ; use File::Slurp ; sub export_ascii { my ($self, $elements_to_save, $file) = @_ ; if($self->{CREATE_BACKUP} && -e $file) { use File::Copy; copy($file,"$file.bak") or die "export_pod: Copy failed while making backup copy: $!"; } write_file($file, $self->transform_elements_to_ascii_buffer()) ; #~ open FH, ">:encoding(utf8)", $file_name; #~ print FH $self->transform_elements_to_ascii_buffer() ; #~ close FH ; return ; } App-Asciio-1.51.3/setup/import_export/asciioe.pl000444001750000144 215712544473514 21335 0ustar00nadimusers000000000000 #---------------------------------------------------------------------------------------------------------------------------- use File::Slurp ; #---------------------------------------------------------------------------------------------------------------------------- register_import_export_handlers ( asciioe => { IMPORT => \&import_asciioe, EXPORT => \&export_asciioe, }, ) ; #---------------------------------------------------------------------------------------------------------------------------- sub import_asciioe { my ($self, $file) = @_ ; my $self_to_resurect= do $file or die "import_asciioe: can't load file '$file': $! $@\n" ; return($self_to_resurect, $file) ; } #---------------------------------------------------------------------------------------------------------------------------- sub export_asciioe { my ($self, $elements_to_save, $file, $data) = @_ ; if($self->{CREATE_BACKUP} && -e $file) { use File::Copy; copy($file,"$file.bak") or die "export_pod: Copy failed while making backup copy: $!"; } write_file($file, $self->serialize_self(1) .'$VAR1 ;') ; return $file ; } App-Asciio-1.51.3/setup/GTK000755001750000144 012544473514 14734 5ustar00nadimusers000000000000App-Asciio-1.51.3/setup/GTK/setup.ini000444001750000144 26312544473514 16713 0ustar00nadimusers000000000000{ STENCILS => [ ], ACTION_FILES => [ 'actions/clipboard.pl', ], HOOK_FILES => [ ], ASCIIO_OBJECT_SETUP => [ ], IMPORT_EXPORT => [ 'import_export/png.pl', ], } App-Asciio-1.51.3/setup/GTK/import_export000755001750000144 012544473514 17647 5ustar00nadimusers000000000000App-Asciio-1.51.3/setup/GTK/import_export/png.pl000444001750000144 111112544473514 21117 0ustar00nadimusers000000000000 register_import_export_handlers ( png => { IMPORT => undef , EXPORT => \&export_png, }, ) ; sub export_png { my ($self, $elements_to_save, $file) = @_ ; if($self->{CREATE_BACKUP} && -e $file) { use File::Copy; copy($file,"$file.bak") or die "export_pod: Copy failed while making backup copy: $!"; } my $alloc = $self->{widget}->allocation; my $pixbuf = Gtk2::Gdk::Pixbuf->get_from_drawable ( $self->{PIXMAP}, $self->{widget}->window->get_colormap, 0, 0, 0, 0, $alloc->width, $alloc->height ); $pixbuf->save($file, "png" ); return ; } App-Asciio-1.51.3/setup/GTK/actions000755001750000144 012544473514 16374 5ustar00nadimusers000000000000App-Asciio-1.51.3/setup/GTK/actions/clipboard.pl000444001750000144 341312544473514 21026 0ustar00nadimusers000000000000 use List::Util qw(min max) ; #---------------------------------------------------------------------------------------------- register_action_handlers ( 'Export to clipboard & primary as ascii'=> ['C00-e', \&export_to_clipboard_as_ascii] , 'Import from clipboard to box'=> ['C0S-E', \&import_from_clipboard_to_box] , 'Import from primary to box'=> ['0A0-e', \&import_from_primary_to_box] , ) ; #---------------------------------------------------------------------------------------------- sub export_to_clipboard_as_ascii { my ($self) = @_ ; my $ascii = $self->transform_elements_to_ascii_buffer($self->get_selected_elements(1)) ; Gtk2::Clipboard->get (Gtk2::Gdk->SELECTION_CLIPBOARD)->set_text($ascii); # also put in selection -- DH Gtk2::Clipboard->get (Gtk2::Gdk->SELECTION_PRIMARY)->set_text($ascii); } #---------------------------------------------------------------------------------------------- sub import_from_clipboard_to_box { my ($self) = @_ ; my $ascii = Gtk2::Clipboard->get (Gtk2::Gdk->SELECTION_CLIPBOARD)->wait_for_text(); my $element = $self->add_new_element_named('stencils/asciio/box', $self->{MOUSE_X}, $self->{MOUSE_Y}) ; $element->set_text('', $ascii) ; $self->select_elements(1, $element) ; $self->update_display() ; } #---------------------------------------------------------------------------------------------- sub import_from_primary_to_box { my ($self) = @_ ; my $ascii = Gtk2::Clipboard->get (Gtk2::Gdk->SELECTION_PRIMARY)->wait_for_text(); my $element = $self->add_new_element_named('stencils/asciio/box', $self->{MOUSE_X}, $self->{MOUSE_Y}) ; $element->set_text('', $ascii) ; $self->select_elements(1, $element) ; $self->update_display() ; } #---------------------------------------------------------------------------------------------- App-Asciio-1.51.3/setup/stencils000755001750000144 012544473514 16133 5ustar00nadimusers000000000000App-Asciio-1.51.3/setup/stencils/divers000444001750000144 164112544473514 17511 0ustar00nadimusers000000000000use strict ; use warnings ; use App::Asciio::Stencil qw(create_box create_element) ; my @ascii = ( 'house' => <<'EOA', ___________ //////|\\\\\\ '.-----------.' | ___ | | [] | | [] | |____|_|____| EOA 'corporate building' => <<'EOA', .-'-. _.-'-._.-'-._ '-. _.-._ .' ' | '-._.-' | |'-_| | |_.'| | |'-|-'| | |'-_| | |_.'| | |'-|-'| | |'-_| | |_.'| | |'-|-'| | ___ .'['-_| | |_.-] .` .' '-'_'-.|.-|_'-' .` ' --..._ '._| _|-'_.' EOA 'building' => <<'EOA', .--------. ,' .'| :-------.'# | | # # # | # | | # # # | # | | # # # | # | | # # # | # | | # # # | # | # # # | EOA ) ; my @boxes ; for(my $ascii_index = 0 ; $ascii_index < $#ascii ; $ascii_index+= 2) { push @boxes, create_box(TEXT_ONLY => $ascii[$ascii_index + 1], NAME => $ascii[$ascii_index], ) ; } [@boxes] ; App-Asciio-1.51.3/setup/stencils/computer000444001750000144 457012544473514 20057 0ustar00nadimusers000000000000use strict ; use warnings ; use App::Asciio::Stencil qw(create_box create_element) ; my @ascii = ( '3D_box' => <<'EOA', .---. / /| .---. | | | ' | |/ '---' EOA 'console' => <<'EOA', ____ | | |____| /::::/ EOA 'computer_small' => <<'EOA', __ _ [__]|=| /::/|_| EOA 'mainframe' => <<'EOA', ________ |==|=====| | | | | | | | | | | | | | |====°| |__|_____| EOA 'Mini' => <<'EOA', ____ |====| | | | | |____| EOA '19_rack' => <<'EOA', __________ [_..._....°] [_..._....°] [_..._....°] [_..._....°] [_|||||||_°] [_|||||||_°] [_|||||||_°] [_________°] [_________°] [_________°] [___....__°] EOA 'rack modem' => <<'EOA', __________ |____oooo_°| EOA 'SAN' => <<'EOA', __________ [_|||||||_°] [_|||||||_°] [_|||||||_°] EOA 'router' => <<'EOA', __________ [_...__...°] EOA 'wireless' => <<'EOA', |_|_| [____°] EOA 'workstation' => <<'EOA', ____ __ | | |==| |____| | | /::::/ |__| EOA 'print server' => <<'EOA', _____ _/____/| /__/__/|| |= |-°||' |___|__|/ EOA 'small_rack' => <<'EOA', ______ [.....°] [.....°] [|||||°] [|||||°] [_____°] [_____°] [_____°] EOA 'modem' => <<'EOA', ______ |_ooo_°| EOA 'firewall' => <<'EOA', _____________________ |___|___|___|___|___|_| |_|___|___|___|___|___| |___|___|___|___|___|_| EOA 'INTERNET' => <<'EOA', .--. _ -( )- _ .--,( ),--. _.-( )-._ ( INTERNET ) '-._( )_.-' '__,( ),__' - ._(__)_. - EOA 'internet' => <<'EOA', .-,( ),-. .-( )-. ( internet ) '-( ).-' '-.( ).-' EOA 'backbone' => <<'EOA', =================================== EOA 'BACKBONE' => <<'EOA', =================================== =================================== =================================== EOA 'document' => <<'EOA', ___ | |\ | '-| | | |_____| EOA 'DB' => <<'EOA', _.-----._ .- -. |-_ _-| | ~-----~ | | | `._ _.' "-----" EOA 'wireless_mast' => <<'EOA', ((.)) | /_\ /___\ / \ EOA ) ; my @boxes ; for(my $ascii_index = 0 ; $ascii_index < $#ascii ; $ascii_index+= 2) { push @boxes, create_box(TEXT_ONLY => $ascii[$ascii_index + 1], NAME => $ascii[$ascii_index], ) ; } [@boxes] ; App-Asciio-1.51.3/setup/stencils/asciio000444001750000144 262112544473514 17463 0ustar00nadimusers000000000000use strict ; use warnings ; use App::Asciio::Stencil qw(create_box create_element) ; [ create_box(WITH_SIZE => [4, 2], WITH_FRAME => 1, TEXT_ONLY => '', NAME => 'box',), create_box(WITH_SIZE => [4, 2], WITH_FRAME => 1, TEXT_ONLY => 'text', NAME => 'shrink_box', AUTO_SHRINK => 1,), create_box( TEXT_ONLY => 'A', NAME => 'text', AUTO_SHRINK => 1,), create_element ( NAME => 'wirl_arrow', CLASS => 'App::Asciio::stripes::section_wirl_arrow', POINTS => [[2, -2, 'up']], DIRECTION => '', ALLOW_DIAGONAL_LINES => 0, EDITABLE => 1, RESIZABLE => 1, ), create_element ( NAME => 'angled_arrow', CLASS => 'App::Asciio::stripes::angled_arrow', END_X => 3, END_Y => -2, DIRECTION => 'up-right', RESIZABLE => 1, ) , create_element ( NAME => 'axis', CLASS => 'App::Asciio::stripes::editable_arrow2', END_X => 3, END_Y => -3, RESIZABLE => 1, ) , create_element ( NAME => 'boxes/if', CLASS => 'App::Asciio::stripes::if_box', TEXT_ONLY => 'condition', EDITABLE => 1, ) , create_element ( NAME => 'boxes/process', CLASS => 'App::Asciio::stripes::process_box', TEXT_ONLY => 'process', EDITABLE => 1, ) , create_box(NAME => 'rulers/0_to_9_vertical', TEXT_ONLY => "0\n1\n2\n3\n4\n5\n6\n7\n8\n9",) , create_box(NAME => 'rulers/01_to_50_horizontal', TEXT_ONLY => '01___5____0____5____0____5____0____5____0____5____0', ), create_box(NAME => 'rulers/0_to_9_horizontal', TEXT_ONLY => '0123456789',), ] ; App-Asciio-1.51.3/setup/stencils/people000444001750000144 171112544473514 17477 0ustar00nadimusers000000000000use strict ; use warnings ; use App::Asciio::Stencil qw(create_box create_element) ; my @ascii = ( 'arms_down' => <<'EOA', o /|\ / \ EOA 'arms_up' => <<'EOA', \o/ | / \ EOA 'Bunny' => <<'EOA', (\_/) (O.o) (> <) EOA 'Dilbert' => <<'EOA', -.-.-,~ . ) ( |_ | /(_)---`\ (_ -' ] | | _,') [_,-'_-'( (_).-' \ / / \ EOA 'BSD_devil' => <<'EOA', , , \\_ /| /- _`-/ ' (/\/ \ /\ O O ) / | `-^--'`< ' (_) _ )/ `.___/` / `--' / <---. __ / __ \ <---|==(fl)=) \ /=== <---' `-' `._,'\ \ / ( ( / \__ ,---_' | \ `-(____) V EOA ) ; my @boxes ; for(my $ascii_index = 0 ; $ascii_index < $#ascii ; $ascii_index+= 2) { push @boxes, create_box(TEXT_ONLY => $ascii[$ascii_index + 1], NAME => $ascii[$ascii_index], ) ; } [@boxes] ; App-Asciio-1.51.3/setup/hooks000755001750000144 012544473514 15432 5ustar00nadimusers000000000000App-Asciio-1.51.3/setup/hooks/canonize_connections.pl000444001750000144 1446012544473514 22361 0ustar00nadimusers000000000000 #~ use Data::TreeDumper ; #---------------------------------------------------------------------------------------------- register_hooks ( ['CANONIZE_CONNECTIONS' => \&canonize_connections], ) ; #---------------------------------------------------------------------------------------------- =pod .-------. | | | .---. | | C | start connector (first character) | C | o | / | O | n | / | N | n | .---. end connector (last character) | N | e | | --------------------------------. / | E | c | '---' | / | C | t | CONNECTED .-|-./ | T | i | | v | | E | o | '---' | E | n | | '---' .------------. | | | Connection | '-------' .----'------------'-----. | | | CONNECTEE | | | '-----------------------' =cut sub canonize_connections { my ($connections) = @_ ; for my $connection (@{$connections}) { if ( ref $connection->{CONNECTED} eq 'App::Asciio::stripes::section_wirl_arrow' && $connection->{CONNECTED}->is_autoconnect_enabled() && $connection->{CONNECTEE}->is_autoconnect_enabled() ) { reconnect_section_wirl_arrow($connection) ; } } } sub reconnect_section_wirl_arrow { my ($connection) = @_ ; my ($connected, $connectee) = ($connection->{CONNECTED}, $connection->{CONNECTEE}) ; my @connectors = $connected->get_all_points() ; my ($start_name, $end_name) = ($connectors[0]{NAME}, $connectors[-1]{NAME}) ; if($connection->{CONNECTOR}{NAME} eq $end_name) { # end connector my ($connectee_x, $connectee_y, $connectee_width, $connectee_hight) = ($connectee->{X}, $connectee->{Y}, $connectee->get_size()) ; my $connected_x = $connected->{X} + $connectors[-2]{X}; my $connected_y = $connected->{Y} + $connectors[-2]{Y}; if($connected_x < $connectee_x) { # arrow starts on left of the box if($connected->get_section_direction(-1) =~ /^right/) { if($connected_y < $connectee_y) { reconnect($connection, 'top_center', $end_name) ; } else { if($connected_y < $connectee_y + $connectee_hight) { reconnect($connection, 'left_center', $end_name) ; } else { # arrow below, right-up to bottom_center reconnect($connection, 'bottom_center', $end_name) ; } } } else { # arrow going up or down reconnect($connection, 'left_center', $end_name) ; } } elsif($connected_x < $connectee_x + $connectee_width) { # arrow starts within width of the box if($connected_y < $connectee_y) { #arrow above, right-down to top_center reconnect($connection, 'top_center', $end_name, 'right') ; } else { reconnect($connection, 'bottom_center', $end_name) ; } } else { # arrow starts on right of the box if($connected->get_section_direction(-1) =~ /^left/) { if($connected_y < $connectee_y) { reconnect($connection, 'top_center', $end_name) ; } else { if($connected_y < $connectee_y + $connectee_hight) { reconnect($connection, 'right_center', $end_name) ; } else { reconnect($connection, 'bottom_center', $end_name) ; } } } else { # arrow going up or down reconnect($connection, 'right_center', $end_name) ; } } } else { # start connector my ($connectee_x, $connectee_y, $connectee_width, $connectee_hight) = ($connectee->{X}, $connectee->{Y}, $connectee->get_size()) ; my $end_connector_x = $connected->{X} + $connectors[1]{X}; my $end_connector_y = $connected->{Y} + $connectors[1]{Y} ; if($end_connector_x < $connectee_x) { # arrow ends on left of the box if($connected->get_section_direction(0) !~ /^left/) { if($end_connector_y < $connectee_y) { reconnect($connection, 'top_center', $start_name) ; } else { if($end_connector_y < $connectee_y + $connectee_hight) { reconnect($connection, 'left_center', $start_name) ; } else { reconnect($connection, 'bottom_center', $start_name) ; } } } else { reconnect($connection, 'left_center', $start_name) ; } } elsif($end_connector_x < $connectee_x + $connectee_width) { # arrow starts within width of the box if($end_connector_y < $connectee_y) { reconnect($connection, 'top_center', $start_name) ; } else { reconnect($connection, 'bottom_center', $start_name) ; } } else { # arrow ends on right of the box if($connected->get_section_direction(0) !~ /^right/) { if($end_connector_y < $connectee_y) { reconnect($connection, 'top_center', $start_name) ; } else { if($end_connector_y < $connectee_y + $connectee_hight) { reconnect($connection, 'right_center', $start_name) ; } else { reconnect($connection, 'bottom_center', $start_name) ; } } } else { reconnect($connection, 'right_center', $start_name) ; } } } } sub reconnect { my($asciio_connection, $connection_name, $connector_name, $hint) = @_ ; if($asciio_connection->{CONNECTION}{NAME} ne $connection_name) { my ($connected, $connectee) = ($asciio_connection->{CONNECTED}, $asciio_connection->{CONNECTEE}) ; my ($connection) = $connectee->get_named_connection($connection_name) ; my ($connector) = $connected->get_named_connection($connector_name) ; my $x_offset_to_connection = ($connectee->{X} + $connection->{X}) - ($connected->{X} + $connector->{X}) ; my $y_offset_to_connection = ($connectee->{Y} + $connection->{Y}) - ($connected->{Y} + $connector->{Y}) ; # move connector #~ print "reconnect: $connection_name $connector_name\n" ; my ($x_offset, $y_offset, $width, $height, $new_connector) = $connected->move_connector($connector_name, $x_offset_to_connection, $y_offset_to_connection, $hint) ; $connected->{X} += $x_offset ; $connected->{Y} += $y_offset ; $asciio_connection->{CONNECTOR} = $new_connector ; $asciio_connection->{CONNECTION} = $connection ; } } App-Asciio-1.51.3/lib000755001750000144 012544473514 13715 5ustar00nadimusers000000000000App-Asciio-1.51.3/lib/App000755001750000144 012544473514 14435 5ustar00nadimusers000000000000App-Asciio-1.51.3/lib/App/Asciio.pm000444001750000144 6225712544473514 16373 0ustar00nadimusers000000000000 package App::Asciio ; $|++ ; use strict; use warnings; use Data::TreeDumper ; use Clone; use List::Util qw(min max first) ; use List::MoreUtils qw(any minmax first_value) ; use App::Asciio::Setup ; use App::Asciio::Dialogs ; use App::Asciio::Elements ; use App::Asciio::Menues ; use App::Asciio::Actions ; use App::Asciio::Undo ; use App::Asciio::Io ; use App::Asciio::Ascii ; use App::Asciio::Options ; #----------------------------------------------------------------------------- our $VERSION = '1.51' ; #----------------------------------------------------------------------------- =head1 NAME App::Asciio - Plain ASCII diagram | | | | | | | | | | | | | | | | v | v | v | v v v _____ _____ /\ _ \ /\ __ \ \ \ \_\ \ ___ ___ _ _\ \ \ \ \ -----> \ \ __ \ / __\ / ___\/\ \/\ \ \ \ \ \ -----> \ \ \ \ \/\__, \/\ \___' \ \ \ \ \ \_\ \ \ \_\ \_\/\____/\ \____/\ \_\ \_\ \_____\ \/_/\/_/\/___/ \/___/ \/_/\/_/\/_____/ | | | | | | | | | | | v | | | v | | | v | | | v | | v v v (\_/) (O.o) ASCII world domination is near! (> <) =head1 SYNOPSIS $> perl asciio.pl =head1 DESCRIPTION It has always been painful to do ASCII diagrams by hand. This perl application allows you to draw ASCII diagrams in a modern (but simple) graphical interface. The ASCII graphs can be saved as ASCII or in a format that allows you to modify them later. Special thanks go to the Muppet and the gtk-perl group, Gábor Szabó for his help and advices. Adam Kennedy coined the cool name. =head1 DOCUMENTATION =head2 Asciio user interface .-----------------------------------------------------------------. | Asciio | |-----------------------------------------------------------------| | ............................................................... | | ..............-------------..------------..--------------...... | | .............| stencils > || asciio > || box |..... | | .............| Rulers > || computer > || text |..... | | .............| File > || people > || wirl_arrow |..... | grid---------->.......'-------------'| divers > || axis |..... | | ......................^.....'------------'| boxes > |..... | | ......................|...................| rulers > |..... | | ......................|...................'--------------'..... | | ......................|........................................ | | ......................|........................................ | | ......................|........................................ | | ......................|........................................ | '-----------------------|-----------------------------------------' | | context menu Press 'F1' for help. =head2 context menu The context menu allows to access to B commands. =head2 keyboard shortcuts All the keyboad commands definitions can be found under I. Among the commands implemented are: =over 2 =item * select all =item * delete =item * undo =item * group/ungroup =item * open / save =item * local clipboard operations =item * send to front/back =item * insert arrow, boxes, text =item * ... =back The available commands are displayed if you press B. =head2 elements There are a few elements implemented at the moment. =head3 wirl arrow An arrow that tries to do what you want. Try rotating the end clockwise then counter clockwise to see how it acts ^ | | --------. | | '------- | | O-------------X / | / | / | / v / / v =head3 multi section wirl arrow A set of whirl arrows connected to each other .----------. . | | \ / \ .-------' ^ \ / \ | \ \ / \ | .-----------> \ ' . | '----. \ / | | \ / '--------' '-------' =head3 angled arrow and axis -------. .------- \ / \ / \ / / \ / \ / \ ------' '------- ^ ^ | ^ \ | / \ | / \ | / <-------- --------> / |\ / | \ / | \ v | v v =head3 box and text .----------. | title | .----------. |----------| ************ | | | body 1 | * * '----------' | body 2 | ************ '----------' anything in a box (\_/) | edit_me (O.o) <------------' (> <) You can also use the 'External commands in box' to direct an external command output to a box. Default shortcuts are 'x' and CTL + 'x'. =head3 "if" box and "process" box ____________ .--------------. \ \ / a == b \ \ \ __________ ( && ) ) process ) \ \ \ 'string' ne '' / / / ) process ) '--------------' /___________/ /_________/ =head3 your own stencils Take a look at I for a stencil example. Stencils listed in I will be loaded when B starts. =head3 your own element type For simple elements, put your design in a box. That should cover 90% of anyone's needs. You can look in I for element implementation examples. =head2 exporting to ASCII You can export to a file in ASCII format but using the B<.txt> extension. Exporting to the clipboard is done with B. =head1 EXAMPLES User code ^ ^ OS code \ / \ / \ / User code <----Mode----->OS code / \ / \ / \ User code v v OS code .---. .---. .---. .---. .---. .---. OS API '---' '---' '---' '---' '---' '---' | | | | | | v v | v | v .------------. | .-----------. | .-----. | Filesystem | | | Scheduler | | | MMU | '------------' | '-----------' | '-----' | | | | v | | v .----. | | .---------. | IO |<----' | | Network | '----' | '---------' | | | v v v .---------------------------------------. | HAL | '---------------------------------------' .---------. .---------. | State 1 | | State 2 | '---------' '---------' ^ \ ^ \ / \ / \ / \ / \ / \ / \ / \ / \ / v v ****** ****** ****** * T1 * * T2 * * T3 * ****** ****** ****** ^ ^ / \ \ / \ \ / \ \ / stimuli \ \ / \ \ v \ .---------. '--------| State 3 | '---------' .--Base::Class::Derived_A / .----Base::Class::Derived_B Something--------. / \ \ / '---Base::Class::Derived::More Something::else \ / \ \ \ / '-Base::Class::Derived::Deeper \ \ / \ \ .-----------Base::Class::Derived_C \ \ / '-------Base::Class / \ \ \ ' \ \ \ | \ \ '---The::Latest /| \ \ \ With::Some::fantasy' ' \ \ '----The::Latest::Greatest /| \ \ More::Stuff' ' \ '-I::Am::Running::Out::Of::Ideas /| \ More::Stuff' ' \ / '---Last::One More::Stuff' ____[] | ___ | || || device ||___|| loads | ooo |------------------------------------------------------------. | ooo | | | | | ooo | | | | '_____' | | | | | | v v v .-------------------. .---------------------------. .-------------------. | Loadable module C | | Loadable module A | | Loadable module B | '-------------------' |---------------------------| | (instrumented) | | | .-----. | '-------------------' '--------------------->| A.o | | | calls | '-----' | | | .------------------. | | | | A.instrumented.o |<-----------------' | '------------------' | calls '---------------------------' =cut sub new { my ($class) = @_ ; my $self = bless { ELEMENT_TYPES => [], ELEMENTS => [], CONNECTIONS => [], CLIPBOARD => {}, FONT_FAMILY => 'Monospace', FONT_SIZE => '10', TAB_AS_SPACES => ' ', OPAQUE_ELEMENTS => 1, DISPLAY_GRID => 1, PREVIOUS_X => -1, PREVIOUS_Y => -1, MOUSE_X => 0, MOUSE_Y => 0, DRAGGING => '', SELECTION_RECTANGLE =>{START_X => 0, START_Y => 0}, KEYS => {K =>{}, C =>{},}, ACTIONS => {}, VALID_SELECT_ACTION => { map {$_, 1} qw(resize move)}, COPY_OFFSET_X => 3, COPY_OFFSET_Y => 3, COLORS => { background => [255, 255, 255], grid => [229, 235, 255], ruler_line => [85, 155, 225], selected_element_background => [180, 244, 255], element_background => [251, 251, 254], element_foreground => [0, 0, 0] , selection_rectangle => [255, 0, 255], test => [0, 255, 255], group_colors => [ [[250, 221, 190], [250, 245, 239]], [[182, 250, 182], [241, 250, 241]], [[185, 219, 250], [244, 247, 250]], [[137, 250, 250], [235, 250, 250]], [[198, 229, 198], [239, 243, 239]], ], connection => 'Chocolate', connection_point => [230, 198, 133], connector_point => 'DodgerBlue', new_connection => 'red' , extra_point => [230, 198, 133], }, NEXT_GROUP_COLOR => 0, WORK_DIRECTORY => '.asciio_work_dir', CREATE_BACKUP => 1, MODIFIED => 0, DO_STACK_POINTER => 0, DO_STACK => [] , }, $class ; return($self) ; } #----------------------------------------------------------------------------- sub event_options_changed { my ($self) = @_; my $number_of_group_colors = scalar(@{$self->{COLORS}{group_colors}}) ; $self->{GROUP_COLORS} = [0 .. $number_of_group_colors - 1] , $self->{CURRENT_ACTIONS} = $self->{ACTIONS} ; $self->set_font($self->{FONT_FAMILY}, $self->{FONT_SIZE}); } #----------------------------------------------------------------------------- sub set_title { my ($self, $title) = @_; if(defined $title) { $self->{TITLE} = $title ; } } sub get_title { my ($self) = @_; $self->{TITLE} ; } #----------------------------------------------------------------------------- sub set_font { my ($self, $font_family, $font_size) = @_; $self->{FONT_FAMILY} = $font_family || 'Monospace'; $self->{FONT_SIZE} = $font_size || 10 ; } sub get_font { my ($self) = @_; return($self->{FONT_FAMILY}, $self->{FONT_SIZE}) ; } #----------------------------------------------------------------------------- sub update_display { my ($self) = @_; $self->call_hook('CANONIZE_CONNECTIONS', $self->{CONNECTIONS}, $self->get_character_size()) ; } sub get_grid_usage { my ($self) = @_; my %cost_map ; # todo: keep previous cost map and update only changed elements for my $element (@{$self->{ELEMENTS}}) { for my $mask_and_element_strip ($element->get_mask_and_element_stripes()) { my $x_offset = $element->{X} + $mask_and_element_strip->{X_OFFSET} ; my $y_offset = $element->{Y} + $mask_and_element_strip->{Y_OFFSET} ; my $string_offset = 0 ; for my $string ( split /\n/, $mask_and_element_strip->{TEXT}) { for (0 .. length($string) - 1 ) { my $x_offset_line = $x_offset + $_ ; my $y_offset_line = ($y_offset + $string_offset) ; $cost_map{"$x_offset_line.$y_offset_line"} = 0 ; } $string_offset++ ; } } } return \%cost_map ; } #----------------------------------------------------------------------------- sub call_hook { my ($self, $hook_name, @arguments) = @_; $self->{HOOKS}{$hook_name}->(@arguments) if (exists $self->{HOOKS}{$hook_name}) ; } #----------------------------------------------------------------------------- sub button_release_event { my ($self, $event) = @_ ; my $modifiers = $event->{MODIFIERS} ; if($self->exists_action("${modifiers}-button_release")) { $self->run_actions(["${modifiers}-button_release", $event]) ; return 1 ; } if(defined $self->{MODIFIED_INDEX} && defined $self->{MODIFIED} && $self->{MODIFIED_INDEX} == $self->{MODIFIED}) { $self->pop_undo_buffer(1) ; # no changes } $self->update_display(); } #----------------------------------------------------------------------------- sub button_press_event { #~ print "button_press_event\n" ; my ($self, $event, $wrapper_event) = @_ ; $self->{DRAGGING} = '' ; delete $self->{RESIZE_CONNECTOR_NAME} ; $self->create_undo_snapshot() ; $self->{MODIFIED_INDEX} = $self->{MODIFIED} ; my $modifiers = $event->{MODIFIERS} ; my $button = $event->{BUTTON} ; if($self->exists_action("${modifiers}-button_press-$button")) { $self->run_actions(["${modifiers}-button_press-$button", $event]) ; return 1 ; } my($x, $y) = @{$event->{COORDINATES}} ; if($event->{TYPE} eq '2button-press') { my @element_over = grep { $self->is_over_element($_, $x, $y) } reverse @{$self->{ELEMENTS}} ; if(@element_over) { my $selected_element = $element_over[0] ; $self->edit_element($selected_element) ; $self->update_display(); } return 1 ; } if($event->{BUTTON} == 1) { my $modifiers = $event->{MODIFIERS} ; my ($first_element) = first_value {$self->is_over_element($_, $x, $y)} reverse @{$self->{ELEMENTS}} ; if ($modifiers eq 'C00') { if(defined $first_element) { $self->run_actions_by_name('Copy to clipboard', ['Insert from clipboard', 0, 0]) ; } } else { if(defined $first_element) { if ($modifiers eq '00S') { $self->select_elements_flip($first_element) ; } else { unless($self->is_element_selected($first_element)) { # make the element under cursor the only selected element $self->select_elements(0, @{$self->{ELEMENTS}}) ; $self->select_elements(1, $first_element) ; } } } else { # deselect all $self->deselect_all_elements() if ($modifiers eq '000') ; } } $self->{SELECTION_RECTANGLE} = {START_X => $x , START_Y => $y} ; $self->update_display(); } if($event->{BUTTON} == 2) { $self->{SELECTION_RECTANGLE} = {START_X => $x , START_Y => $y} ; $self->update_display(); } if($event->{BUTTON} == 3) { $self->display_popup_menu($wrapper_event) ; # display_popup_menu is handled by derived Asciio } return 1; } #----------------------------------------------------------------------------- sub motion_notify_event { my ($self, $event) = @_ ; my($x, $y) = @{$event->{COORDINATES}} ; my $modifiers = $event->{MODIFIERS} ; my $button = $event->{BUTTON} ; if($self->exists_action("${modifiers}motion_notify")) { $self->run_actions(["${modifiers}-motion_notify", $event]) ; return 1 ; } if($self->{PREVIOUS_X} != $x || $self->{PREVIOUS_Y} != $y) { ($self->{MOUSE_X}, $self->{MOUSE_Y}) = ($x, $y) ; $self->update_display() ; } if ($event->{STATE} >= "button1-mask") { if($self->{DRAGGING} ne '') { if ($self->{DRAGGING} eq 'move') { $self->move_elements_event($x, $y) ; } elsif ($self->{DRAGGING}eq 'resize') { $self->resize_element_event($x, $y) ; } elsif ($self->{DRAGGING}eq 'select') { $self->select_element_event($x, $y) ; } } else { my @selected_elements = $self->get_selected_elements(1) ; my ($first_element) = first_value {$self->is_over_element($_, $x, $y)} reverse @selected_elements ; if(@selected_elements > 1) { if(defined $first_element) { $self->{DRAGGING} = 'move' ; } else { $self->{DRAGGING} = 'select' ; } } else { if(defined $first_element) { $self->{DRAGGING} = $first_element->get_selection_action ( $x - $first_element->{X}, $y - $first_element->{Y}, ); $self->{DRAGGING} ='' unless exists $self->{VALID_SELECT_ACTION}{$self->{DRAGGING}} ; } else { $self->{DRAGGING} = 'select' ; } } ($self->{PREVIOUS_X}, $self->{PREVIOUS_Y}) = ($x, $y) ; } } if ($event->{STATE} >= "button2-mask") { $self->select_element_event($x, $y, $self->{MIDDLE_BUTTON_SELECTION_FILTER} || sub{1}) ; } return 1; } #----------------------------------------------------------------------------- sub select_element_event { my ($self, $x, $y, $filter) = @_ ; my ($x_offset, $y_offset) = ($x - $self->{PREVIOUS_X}, $y - $self->{PREVIOUS_Y}) ; if($x_offset != 0 || $y_offset != 0) { $self->{SELECTION_RECTANGLE}{END_X} = $x ; $self->{SELECTION_RECTANGLE}{END_Y} = $y ; $filter = sub {1} unless defined $filter ; $self->select_elements ( 1, grep { $filter->($_) } grep # elements within selection rectangle { $self->element_completely_within_rectangle ( $_, $self->{SELECTION_RECTANGLE}, ) } @{$self->{ELEMENTS}} ) ; $self->update_display(); ($self->{PREVIOUS_X}, $self->{PREVIOUS_Y}) = ($x, $y) ; } } #----------------------------------------------------------------------------- sub move_elements_event { my ($self, $x, $y) = @_; my ($x_offset, $y_offset) = ($x - $self->{PREVIOUS_X}, $y - $self->{PREVIOUS_Y}) ; if($x_offset != 0 || $y_offset != 0) { my @selected_elements = $self->get_selected_elements(1) ; $self->move_elements($x_offset, $y_offset, @selected_elements) ; $self->update_display(); ($self->{PREVIOUS_X}, $self->{PREVIOUS_Y}) = ($x, $y) ; } } #----------------------------------------------------------------------------- sub resize_element_event { my ($self, $x, $y) = @_ ; my ($x_offset, $y_offset) = ($x - $self->{PREVIOUS_X}, $y - $self->{PREVIOUS_Y}) ; if($x_offset != 0 || $y_offset != 0) { my ($selected_element) = $self->get_selected_elements(1) ; $self->{RESIZE_CONNECTOR_NAME} = $self->resize_element ( $self->{PREVIOUS_X} - $selected_element->{X}, $self->{PREVIOUS_Y} - $selected_element->{Y} , $x - $selected_element->{X}, $y - $selected_element->{Y} , $selected_element, $self->{RESIZE_CONNECTOR_NAME}, ) ; $self->update_display(); ($self->{PREVIOUS_X}, $self->{PREVIOUS_Y}) = ($x, $y) ; } } #----------------------------------------------------------------------------- sub key_press_event { my ($self, $event)= @_; my $modifiers = $event->{MODIFIERS} ; my $key = $self->{KEYS}{C}{$event->{KEY_VALUE}} ; $self->run_actions("$modifiers-$key") ; return 0 ; } #----------------------------------------------------------------------------- sub get_character_size { my ($self) = @_ ; if(exists $self->{USER_CHARACTER_WIDTH}) { return ($self->{USER_CHARACTER_WIDTH}, $self->{USER_CHARACTER_HEIGHT}) ; } else { return (8, 16) ; } } #----------------------------------------------------------------------------- sub set_character_size { my ($self, $width, $height) = @_ ; ($self->{USER_CHARACTER_WIDTH}, $self->{USER_CHARACTER_HEIGHT}) = ($width, $height) ; } #----------------------------------------------------------------------------- sub get_color { my ($self, $name) = @_; unless (exists $self->{ALLOCATED_COLORS}{$name}) { my $color = [255, 0, 0]; $self->{ALLOCATED_COLORS}{$name} = $color ; } return($self->{ALLOCATED_COLORS}{$name}) ; } #----------------------------------------------------------------------------- sub flush_color_cache { my ($self) = @_ ; delete $self->{ALLOCATED_COLORS} ; } #----------------------------------------------------------------------------- =head1 DEPENDENCIES gnome libraries, gtk, gtk-perl for the gtk version =head1 BUGS AND LIMITATIONS Undoubtedly many as I wrote this as a fun little project where I used no design nor 'methodic' whatsoever. =head1 AUTHOR Khemir Nadim ibn Hamouda CPAN ID: NKH mailto:nadim@khemir.net =head1 LICENSE AND COPYRIGHT This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SUPPORTED OSes =head2 Gentoo I run gentoo, packages to install gtk-perl exist. Install Asciio with cpan. =head2 FreeBSD FreeBSD users can now install asciio either by package: $ pkg_add -r asciio or from source (out of the ports system) by: $ cd /usr/ports/graphics/asciio $ make install clean Thanks to Emanuel Haupt. =head2 Ubuntu and Debian Ports are on the way. =head2 Windows B is part of the B distribution and can be found here: L. Install, run AsciiO from the 'bin' directory. .-------------------------------. / /| / camelbox for win32 / | / / | / / | .-------------------------------. | | ______\\_, | | | (_. _ o_ _/ | | | '-' \_. / | | | / / | | | / / .--. .--. | | | ( ( / '' \/ '' \ " | | | \ \_.' \ ) | | | || _ './ | | | |\ \ ___.'\ / | | | '-./ .' \ |/ | | | \| / )|\ | | | |/ // \\ | . | |\ __// \\__ | / | //\\ /__/ mrf\__| | / | .--_/ \_--. | / | /__/ \__\ |/ '-------------------------------' B is a great distribution for windows. I hope it will merge with X-berry series of Perl distributions. =head1 Mac OsX This works too (and I have screenshots to prove it :). I don't own a mac and the mac user hasn't send me how to do it yet. =head1 other unices YMMV, install gtk-perl and AsciiO from cpan. =head1 SEE ALSO http://www.jave.de http://search.cpan.org/~osfameron/Text-JavE-0.0.2/JavE.pm http://ditaa.sourceforge.net/ http://www.codeproject.com/KB/macros/codeplotter.aspx http://search.cpan.org/~jpierce/Text-FIGlet-1.06/FIGlet.pm http://www.fossildraw.com/?gclid=CLanxZXxoJECFRYYEAodnBS8Dg (doesn't always respond) http://www.ascii-art.de (used some entries as base for the network stencil) http://c2.com/cgi/wiki?UmlAsciiArt http://www.textfiles.com/art/ http://www2.b3ta.com/_bunny/texbunny.gif *\o_ _o/* / * * \ <\ *\o/* /> ) o/* / > *\o <\ /> __o */\ /\* o__ * /> <\ * /\* __o_ _o__ */\ * / * * \ * <\ /> *\o/* ejm97 __)__ =cut #------------------------------------------------------------------------------------------------------ "ASCII world domination!" ; App-Asciio-1.51.3/lib/App/Asciio000755001750000144 012544473514 15644 5ustar00nadimusers000000000000App-Asciio-1.51.3/lib/App/Asciio/Undo.pm000444001750000144 1570612544473514 17275 0ustar00nadimusers000000000000 package App::Asciio ; $|++ ; use strict; use warnings; use Data::TreeDumper ; #~ use Compress::LZF ':compress'; use Compress::Bzip2 qw(:all :utilities :gzip); #----------------------------------------------------------------------------- sub pop_undo_buffer { my ($self, $number_of_steps) = @_; pop @{$self->{DO_STACK}} for(1 .. $number_of_steps) ; } #----------------------------------------------------------------------------- sub redo { my ($self, $number_of_steps) = @_; $self->{DO_STACK_POINTER} += $number_of_steps ; if($self->{DO_STACK_POINTER} >= @{$self->{DO_STACK}}) { $self->{DO_STACK_POINTER} = @{$self->{DO_STACK}} - 1 ; } $self->do($self->{DO_STACK_POINTER}) ; } sub undo { my ($self, $number_of_steps) = @_; (my $new_stack_pointer = $self->{DO_STACK_POINTER}) -= $number_of_steps ; $new_stack_pointer = 0 if($new_stack_pointer < 0) ; $self->{DO_STACK} ||= [] ; if($self->{DO_STACK_POINTER} == @{$self->{DO_STACK}}) { $self->create_undo_snapshot() ; } $self->{DO_STACK_POINTER} = $new_stack_pointer ; $self->do($new_stack_pointer) ; } sub do { my ($self, $stack_pointer) = @_; my $new_self = $self->{DO_STACK}[$stack_pointer] ; if(defined $new_self) { my ($do_stack_pointer, $do_stack) = ($self->{DO_STACK_POINTER}, $self->{DO_STACK}) ; my $decompressed_new_self = decompress $new_self ; $decompressed_new_self .= "\n\n" ; # important line or eval would complain about syntax errors !!! my $VAR1 ; eval $decompressed_new_self ; if($@) { use File::Slurp ; write_file('undo_error.pl', $decompressed_new_self ) ; die "Can't undo! $@\n" ; } else { $self->load_self($VAR1) ; ($self->{DO_STACK_POINTER}, $self->{DO_STACK}) = ($do_stack_pointer, $do_stack) ; $self->set_modified_state(1) ; $self->update_display() ; } } else { $self->set_modified_state(0) ; } } #----------------------------------------------------------------------------- sub create_undo_snapshot { my ($self) = @_; #TODO: delta, serialize and compress, use the same huffman table for extra compression my $serialized_self ; { local $self->{DO_STACK} = undef ; $serialized_self = $self->serialize_self() ; } #~ my $previous_serialized_self = '' ; #~ { #~ local $self->{DO_STACK} = undef ; #~ my $xxx= $self->serialize_self(1) ; #~ use File::Slurp ; #~ write_file("test/undo_$self->{DO_STACK_POINTER}.txt", $xxx) ; # diff serialize 1 + bzip 2 => 500-1000 bytes vs 4000-5000 bytes with no diff and compress #~ } my $compressed_self = compress $serialized_self ; splice(@{$self->{DO_STACK}}, min($self->{DO_STACK_POINTER}, scalar(@{$self->{DO_STACK}}))) ; # new do branch push @{$self->{DO_STACK}}, $compressed_self ; $self->{DO_STACK_POINTER} = @{$self->{DO_STACK}} ; #~ print 'stack: ' . scalar(@{$self->{DO_STACK}}) . ' size: ' . length($serialized_self) . ' compressed: ' . length($compressed_self) . "\n" ; } #----------------------------------------------------------------------------- use Algorithm::Diff qw(diff LCS traverse_sequences) ; sub test_diff { # This example produces traditional 'diff' output: my @seq1 = ("line 1", "line 2", "line3", "line 4", "line 5", 'line 6') ; my @seq2 = ("line mod1", "line 2", "line 2B", "line3", "line 5") ; my @diff_lines = get_diff_lines(\@seq1, \@seq2) ; for my $diff_line (@diff_lines) { print DumpTree $diff_line ; my ( $number_of_errors , $number_of_match , $synchronized_a , $synchronized_b , $error_string ) = CompareStrings($diff_line->{REFERENCE}, $diff_line->{NEW}) ; my $undefined_line = '' ; $undefined_line = '** reference line did not exist! **' unless defined $diff_line->{REFERENCE} ; $undefined_line = '** new line did not exist! **' unless defined $diff_line->{NEW} ; print <{LINE} number_of_match = $number_of_match number_of_errors = $number_of_errors $undefined_line $synchronized_a $synchronized_b $error_string ERRORS } } sub get_diff_lines { my ($seq1, $seq2) = @_ ; my $diff = Algorithm::Diff->new($seq1, $seq2 ); my @diff_lines ; $diff->Base(1); my $line = 1 ; while($diff->Next()) { unless($diff->Same()) { my ($reference_line) = $diff->Items(1) ; my ($new_line) = $diff->Items(2) ; push @diff_lines, {LINE => $line, REFERENCE => $reference_line , NEW => $new_line} ; } $line++ ; } return @diff_lines ; } sub CompareStrings($$) { =head2 CompareStrings Returns the following list: =over 2 =item 1 number_of_errors =item 2 number_of_match =item 3 synchronized_a =item 4 synchronized_b =item 5 error_string =back =cut my ($a_string, $b_string) = @_ ; my ($a, $b) ; # handle cases were one or both strings are not defined if(!defined $a_string && ! defined $b_string) { return (0, 0, '', '', '') ; } elsif(!defined $a_string) { return (length($b_string), 0, '', $b_string, '^' x length($b_string)) ; } elsif(!defined $b_string) { return (length($a_string), 0, $a_string, '', '^' x length($a_string)) ; } my @a = split //, $a_string ; my @b = split //, $b_string ; my @match_indexes = Algorithm::Diff::_longestCommonSubsequence( \@a, \@b) ; #print Dumper(\@match_indexes), "\n" ; #my @LCS = LCS( \@a, \@b ) ; #print Dumper(\@LCS), "\n" ; my $previous = -1 ; my $last_match_in_B = -1 ; # build $a a character at a time. Synchronize strings before adding current character for(0 .. $#match_indexes) { if(defined $previous) { if(defined $match_indexes[$_]) { if($match_indexes[$_] == $previous + 1) { # match $b .= $b[$match_indexes[$_]] ; $last_match_in_B = $match_indexes[$_] ; } else { # match but extra letters in B, synchronize A $a .= ' ' x ($match_indexes[$_] - ($previous + 1)) ; $b .= join '', @b[$previous + 1 .. $match_indexes[$_]] ; $last_match_in_B = $match_indexes[$_] ; } } #else # letter in A doesn't match in B } else { if(defined $match_indexes[$_]) { # match # synchronize B my $number_of_skipped_characters_in_B = ($match_indexes[$_] - 1) - ($last_match_in_B) ; $b .= ' ' x (length($a) - (length($b) + $number_of_skipped_characters_in_B)) ; $b .= join '', @b[$last_match_in_B + 1 .. $match_indexes[$_]] ; $last_match_in_B = $match_indexes[$_] ; # synchronize A if needed $a .= ' ' x (length($b) - (length($a) + 1)) ; # +1 as current character will be appended to $a } #else # letter in A doesn't match in B } $a .= $a[$_] ; $previous = $match_indexes[$_] ; } my $trailers_in_A = scalar(@a) - scalar(@match_indexes) ; $a .= join '', @a[-$trailers_in_A .. -1] ; my $trailers_in_B = scalar(@b) - ($last_match_in_B + 1) ; $b .= join '', @b[-$trailers_in_B .. -1] ; my $error_string = $a ^ $b ; my $number_of_matches = $error_string =~ tr[\0][\0] ; my $number_of_errors = length($error_string) - $number_of_matches ; # show were the strings are different $error_string =~ tr[\0][^]c ; $error_string =~ tr[\0][ ] ; return ($number_of_errors, $number_of_matches, $a, $b, $error_string) ; } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.51.3/lib/App/Asciio/Stencil.pm000444001750000144 322612544473514 17743 0ustar00nadimusers000000000000package App::Asciio::Stencil ; #~ package App::Asciio ; use strict ; use warnings ; use Readonly ; BEGIN { use Sub::Exporter -setup => { exports => [ qw(create_box create_element) ] } ; } sub create_box { my (%element_definition) = @_ ; use App::Asciio::stripes::editable_box2 ; my $element = new App::Asciio::stripes::editable_box2 ({ TEXT_ONLY => '', TITLE => '', EDITABLE => 1, RESIZABLE => 1, %element_definition, }) ; unless($element_definition{WITH_FRAME}) { # default object attribute is with frame, remove it my $box_type = $element->get_box_type() ; my ($title, $text) = $element->get_text() ; Readonly my $TITLE_SEPARATOR => 1 ; Readonly my $DISPLAY => 0 ; for (0 .. $#$box_type) { next if $_ == $TITLE_SEPARATOR && $title eq '' ; $box_type->[$_][$DISPLAY] = 0 ; } $element->set_box_type($box_type) ; } $element->shrink() ; if($element_definition{WITH_SIZE}) { $element->resize(0, 0, @{$element_definition{WITH_SIZE}}) ; } # add name to be seen in the stencil list $element->{NAME} = $element_definition{NAME} ; return $element ; } sub create_element { my (%element_definition) = @_ ; my $element ; my $code = <<"EOE" ; use $element_definition{CLASS} ; \$element = new $element_definition{CLASS} (\\%element_definition) ; \$element->{NAME} = \$element_definition{NAME} ; EOE eval $code ; if($@) { use Data::TreeDumper ; warn "Can't create new element with definition:\n" ; warn DumpTree \%element_definition ; warn $code ; warn $@ ; } return $element ; } #---------------------------------------------------------------------------------------------------------------------- 1 ; App-Asciio-1.51.3/lib/App/Asciio/Options.pm000444001750000144 421012544473514 17767 0ustar00nadimusers000000000000 package App::Asciio ; $|++ ; use strict; use warnings; use Data::TreeDumper ; use Getopt::Long ; #----------------------------------------------------------------------------- sub ParseSwitches { my ($self, $switches_to_parse, $ignore_error) = @_ ; my $asciio_config = {} ; Getopt::Long::Configure('no_auto_abbrev', 'no_ignore_case', 'require_order') ; my @flags = Get_GetoptLong_Data($asciio_config) ; @ARGV = @{$switches_to_parse} ; # tweek option parsing so we can mix switches with targets my $contains_switch ; my @targets ; do { while(@ARGV && $ARGV[0] !~ /^-/) { #~ print "target => $ARGV[0] \n" ; push @targets, shift @ARGV ; } $contains_switch = @ARGV ; local $SIG{__WARN__} = sub {print STDERR $_[0] unless $ignore_error ;} ; unless(GetOptions(@flags)) { return(0, "Try perl asciio -h.", $asciio_config, @ARGV) unless $ignore_error; } } while($contains_switch) ; $asciio_config->{TARGETS} = \@targets ; #~ use Data::TreeDumper ; #~ print DumpTree $asciio_config ; return(1, '', $asciio_config) ; } #------------------------------------------------------------------------------- sub Get_GetoptLong_Data { my $asciio_config = shift || die 'Missing argument.' ; my @flags_and_help = GetSwitches($asciio_config) ; my $flag_element_counter = 0 ; my @getoptlong_data ; for (my $i = 0 ; $i < @flags_and_help; $i += 4) { my ($flag, $variable) = ($flags_and_help[$i], $flags_and_help[$i + 1]) ; push @getoptlong_data, ($flag, $variable) ; } return(@getoptlong_data) ; } #------------------------------------------------------------------------------- sub GetSwitches { my $asciio_config = shift || {} ; $asciio_config->{SETUP_PATHS} = [] ; my @flags_and_help = ( 'setup_path=s' => $asciio_config->{SETUP_PATHS}, 'Sets the root of the setup directory.', '', 's|script=s' => \$asciio_config->{SCRIPT}, 'script to be run at AsciiO start.', '', 'h|help' => \$asciio_config->{HELP}, 'Displays some help.', '', ) ; return(@flags_and_help) ; } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.51.3/lib/App/Asciio/Connections.pm000444001750000144 1053212544473514 20642 0ustar00nadimusers000000000000 package App::Asciio; $|++ ; use strict; use warnings; use Data::TreeDumper ; use Clone; use List::Util qw(min max) ; use List::MoreUtils qw(any minmax first_value) ; #----------------------------------------------------------------------------- sub connect_elements { my ($self, @elements) = @_ ; my @possible_connections = $self->get_possible_connections(@elements) ; #~ $self->show_dump_window(\@possible_connections, "\@possible_connections for @elements") ; $self->add_connections(@possible_connections) ; } #----------------------------------------------------------------------------- sub add_connections { my ($self, @connections) = @_ ; $self->flash_new_connections(@connections) ; push @{$self->{CONNECTIONS}}, @connections ; $self->{MODIFIED }++ ; } #----------------------------------------------------------------------------- sub get_possible_connections { my ($self, @elements) = @_ ; my @possible_connections ; my %connected_connectors ; for my $element (@elements) { my @connectors = $element->get_connector_points() ; last unless @connectors ; #optimize search by eliminating those elements that are too far for my $connectee (reverse @{$self->{ELEMENTS}}) { next if $connectee == $element ; # dont connect to self for my $connector (@connectors) { my @connections = $connectee->match_connector ( # translate coordinates to connectee reference ($element->{X} - $connectee->{X}) + $connector->{X}, ($element->{Y} - $connectee->{Y}) + $connector->{Y}, ) ; # make connection if possible. connect to a single point if(defined $connections[0] && ! exists $connected_connectors{$element.$connector->{NAME}}) { push @possible_connections, { CONNECTED => $element, CONNECTOR =>$connector, CONNECTEE => $connectee, CONNECTION => $connections[0], } ; $connected_connectors{$element.$connector->{NAME}}++ ; next ; } } } } return(@possible_connections) ; } #----------------------------------------------------------------------------- sub get_connections_containing { my($self, @elements) = @_ ; my %elements_to_find = map {$_ => 1} @elements ; my @connections ; for my $connection (@{$self->{CONNECTIONS}}) { if(exists $elements_to_find{$connection->{CONNECTED}} || exists $elements_to_find{$connection->{CONNECTEE}}) { push @connections, $connection; } } return(@connections) ; } #----------------------------------------------------------------------------- sub delete_connections { my($self, @connections) = @_ ; my %connections_to_delete = map {$_ => 1} @connections ; for my $connection (@{$self->{CONNECTIONS}}) { if(exists $connections_to_delete{$connection}) { $connection = undef ; } } @{$self->{CONNECTIONS}} = grep { defined $_} @{$self->{CONNECTIONS}} ; $self->{MODIFIED }++ ; } #----------------------------------------------------------------------------- sub delete_connections_containing { my($self, @elements) = @_ ; for my $element(@elements) { for my $connection (@{$self->{CONNECTIONS}}) { if($connection->{CONNECTED} == $element || $connection->{CONNECTEE} == $element) { $connection = undef ; } } } @{$self->{CONNECTIONS}} = grep { defined $_} @{$self->{CONNECTIONS}} ; $self->{MODIFIED }++ ; } #----------------------------------------------------------------------------- sub is_connectee { my($self, $element) = @_ ; my $connectee = 0 ; for my $connection (@{$self->{CONNECTIONS}}) { if($connection->{CONNECTEE} == $element) { $connectee++ ; last } } return($connectee) ; } sub get_connected { my($self, $element) = @_ ; my(@connected) ; for my $connection (@{$self->{CONNECTIONS}}) { if($connection->{CONNECTEE} == $element) { push @connected, $connection ; } } return(@connected) ; } #----------------------------------------------------------------------------- sub is_connected { my($self, $element) = @_ ; my $connected = 0 ; for my $connection (@{$self->{CONNECTIONS}}) { if($connection->{CONNECTED} == $element) { $connected++ ; last } } return($connected) ; } #----------------------------------------------------------------------------- sub flash_new_connections { my($self, @connections) = @_ ; push @{$self->{NEW_CONNECTIONS}}, @connections ; } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.51.3/lib/App/Asciio/Ascii.pm000444001750000144 237612544473514 17377 0ustar00nadimusers000000000000 package App::Asciio; $|++ ; use strict; use warnings; #----------------------------------------------------------------------------- sub transform_elements_to_ascii_buffer { my ($self, @elements) = @_ ; return(join("\n", $self->transform_elements_to_ascii_array(@elements)) . "\n") ; } #----------------------------------------------------------------------------- sub transform_elements_to_ascii_array { my ($self, @elements) = @_ ; @elements = @{$self->{ELEMENTS}} unless @elements ; my @lines ; for my $element (@elements) { for my $strip ($element->get_mask_and_element_stripes()) { my $line_index = 0 ; for my $sub_strip (split("\n", $strip->{TEXT})) { my $character_index = 0 ; for my $character (split '', $sub_strip) { my $x = $element->{X} + $strip->{X_OFFSET} + $character_index ; my $y = $element->{Y} + $strip->{Y_OFFSET} + $line_index ; $lines[$y][$x] = $character if ($x >= 0 && $y >= 0) ; $character_index ++ ; } $line_index++ ; } } } my @ascii; for my $line (@lines) { my $ascii_line = join('', map {defined $_ ? $_ : ' '} @{$line}) ; push @ascii, $ascii_line; } return(@ascii) ; } #----------------------------------------------------------------------------- 1 ;App-Asciio-1.51.3/lib/App/Asciio/Menues.pm000444001750000144 44512544473514 17556 0ustar00nadimusers000000000000 package App::Asciio ; use strict; use warnings; #------------------------------------------------------------------------------------------------------ sub display_popup_menu { } #------------------------------------------------------------------------------------------------------ 1 ; App-Asciio-1.51.3/lib/App/Asciio/Actions.pm000444001750000144 621712544473514 17745 0ustar00nadimusers000000000000 package App::Asciio ; $|++ ; use strict; use warnings; #------------------------------------------------------------------------------------------------------ my Readonly $SHORTCUTS = 0 ; my Readonly $CODE = 1 ; my Readonly $ARGUMENTS = 2 ; my Readonly $CONTEXT_MENUE_SUB = 3 ; my Readonly $CONTEXT_MENUE_ARGUMENTS = 4 ; my Readonly $NAME= 5 ; my Readonly $ORIGIN= 6 ; sub run_actions { my ($self, @actions) = @_ ; my @results ; for my $action (@actions) { my @arguments ; if('ARRAY' eq ref $action) { ($action, @arguments) = @{ $action } ; } my ($modifiers, $action_key) = $action =~ /(...)-(.*)/ ; if(exists $self->{CURRENT_ACTIONS}{$action}) { if('HASH' eq ref $self->{CURRENT_ACTIONS}{$action}) { my $action_group_name = $self->{CURRENT_ACTIONS}{$action}{GROUP_NAME} || 'unnamed action group' ; print "using action handlers group '$action_group_name'" . "[$self->{CURRENT_ACTIONS}{$action}{ORIGIN}].\n" ; $self->{CURRENT_ACTIONS} = $self->{CURRENT_ACTIONS}{$action} ; } else { print "Handling input '$modifiers + $action_key' with action '$self->{CURRENT_ACTIONS}{$action}[$NAME]'" . "[$self->{CURRENT_ACTIONS}{$action}[$ORIGIN]].\n" ; if(defined $self->{CURRENT_ACTIONS}{$action}[$ARGUMENTS]) { push @results, [ $self->{CURRENT_ACTIONS}{$action}[$CODE]-> ( $self, $self->{CURRENT_ACTIONS}{$action}[$ARGUMENTS], @arguments ) ] ; } else { push @results, [ $self->{CURRENT_ACTIONS}{$action}[$CODE]->($self, @arguments) ] ; } } } else { print "no handler for input '$modifiers + $action_key'.\n" ; $self->{CURRENT_ACTIONS} = $self->{ACTIONS} ; } } return @results ; } #------------------------------------------------------------------------------------------------------ sub run_actions_by_name { my ($self, @actions) = @_ ; my @results ; my $current_actions_by_name = $self->{ACTIONS_BY_NAME} ; for my $action (@actions) { my @arguments ; if('ARRAY' eq ref $action) { ($action, @arguments) = @{ $action } ; } if(exists $current_actions_by_name->{$action}) { if('HASH' eq ref $self->{CURRENT_ACTIONS}{$action}) { print "using action handlers group '$action'\n" ; $current_actions_by_name = $self->{CURRENT_ACTIONS}{$action} ; } else { print "running action '$action'.\n" ; if(defined $current_actions_by_name->{$action}[$ARGUMENTS]) { push @results, [ $current_actions_by_name->{$action}[$CODE]-> ( $self, $self->{CURRENT_ACTIONS}{$action}[$ARGUMENTS], @arguments ) ] ; } else { push @results, [ $current_actions_by_name->{$action}[$CODE]->($self, @arguments) ] ; } } } else { print "no handler for '$action'.\n" ; last ; } } return @results ; } #------------------------------------------------------------------------------------------------------ sub exists_action { my ($self, $action) = @_ ; return exists $self->{CURRENT_ACTIONS}{$action} ; } #------------------------------------------------------------------------------------------------------ 1 ; App-Asciio-1.51.3/lib/App/Asciio/Io.pm000444001750000144 1430312544473514 16727 0ustar00nadimusers000000000000 package App::Asciio ; $|++ ; use strict; use warnings; use Data::Dumper ; use Data::TreeDumper ; use File::Slurp ; use Readonly ; #~ use Compress::LZF ':compress'; use Compress::Bzip2 qw(:all :utilities :gzip); #----------------------------------------------------------------------------- sub load_file { my ($self, $file_name) = @_; return unless defined $file_name ; my ($base_name, $path, $extension) = File::Basename::fileparse($file_name, ('\..*')) ; $extension =~ s/^\.// ; my $type = $extension ne q{} ? $extension : 'internal_asciio_format'; my $title ; if ( exists $self->{IMPORT_EXPORT_HANDLERS}{$type}{IMPORT} && defined $self->{IMPORT_EXPORT_HANDLERS}{$type}{IMPORT} ) { my ($saved_self, $handler_data) ; ($saved_self, $title, $handler_data) = $self->{IMPORT_EXPORT_HANDLERS}{$type}{IMPORT}-> ( $self, $file_name, ) ; $self->load_self($saved_self) ; # resurect from momified $self->{IMPORT_EXPORT_HANDLERS}{HANDLER_DATA} = $handler_data ; } else { if(-e $file_name && -s $file_name) { my $serialized_self = decompress(read_file($file_name)) ; $serialized_self .= "\n\n" ; my $VAR1 ; my $saved_self = eval $serialized_self ; if($@) { write_file("failed_resurection_source.pl", $serialized_self) ; die "load_file: can't load file '$file_name': $! $@\n" ; } $self->load_self($saved_self) ; # resurect delete $self->{IMPORT_EXPORT_HANDLERS}{HANDLER_DATA} ; $title = $file_name ; } else { my $element = $self->add_new_element_named('stencils/asciio/box', 0, 0) ; my $box_type = $element->get_box_type() ; $box_type->[1][0] = 1 ; # title separator $element->set_box_type($box_type) ; $element->set_text('Warning!', 'The file you wanted to open had no content.'); $self->select_elements(1, $element) ; $self->update_display() ; $title = $file_name ; } } return $title ; } #----------------------------------------------------------------------------- Readonly my @ELEMENTS_TO_KEEP_FROM_CURRENT_OBJECT => qw ( widget PIXMAP ALLOCATED_COLORS ACTIONS CURRENT_ACTIONS ACTIONS_BY_NAME HOOKS IMPORT_EXPORT_HANDLERS TITLE ELEMENT_TYPES_BY_NAME ELEMENT_TYPES MIDDLE_BUTTON_SELECTION_FILTER ) ; sub load_self { my ($self, $new_self) = @_; return unless defined $new_self ; delete @{$new_self}{@ELEMENTS_TO_KEEP_FROM_CURRENT_OBJECT} ; my @keys = keys %{$new_self} ; @{$self}{@keys} = @{$new_self}{@keys} ; } #----------------------------------------------------------------------------- sub load_elements { my ($self, $file_name, $path) = @_; return unless defined $file_name ; my $elements = do $file_name or die "can't load file '$file_name': $! $@\n" ; $path = '' unless defined $path ; for my $new_element (@{$elements}) { my $new_element_type = ref $new_element or die "element without type in file '$file_name'!" ; unless(exists $self->{LOADED_TYPES}{$new_element_type}) { eval "use $new_element_type" ; die "Error loading type '$new_element_type' :$@" if $@ ; $self->{LOADED_TYPES}{$new_element_type}++ ; } my $next_element_type_index = @{$self->{ELEMENT_TYPES}} ; $new_element->{NAME} = "$path/$new_element->{NAME}" ; $new_element->{NAME} =~ s~/+~/~g ; $new_element->{NAME} =~ s~^/~~g ; #~ print $new_element->{NAME} . "\n" ; if(exists $new_element->{NAME}) { if(exists $self->{ELEMENT_TYPES_BY_NAME}{$new_element->{NAME}}) { print "Overriding element type '$new_element->{NAME}'!\n" ; $self->{ELEMENT_TYPES}[$self->{ELEMENT_TYPES_BY_NAME}{$new_element->{NAME}}] = $new_element ; } else { $self->{ELEMENT_TYPES_BY_NAME}{$new_element->{NAME}} = $next_element_type_index ; push @{$self->{ELEMENT_TYPES}}, $new_element ; $next_element_type_index++ ; } } if(exists $new_element->{X}) { push @{$self->{ELEMENTS}}, $new_element ; } } } #----------------------------------------------------------------------------- sub save_stencil { my ($self) = @_ ; my $name = $self->display_edit_dialog('stencil name') ; if(defined $name && $name ne q[]) { my $file_name = $self->get_file_name('save') ; if(defined $file_name && $file_name ne q[]) { if(-e $file_name) { my $override = $self->display_yes_no_cancel_dialog ( "Override file!", "File '$file_name' exists!\nOverride file?" ) ; $file_name = undef unless $override eq 'yes' ; } } if(defined $file_name && $file_name ne q[]) { use Data::Dumper ; my ($element) = $self->get_selected_elements(1) ; my $stencil = Clone::clone($element) ; delete $stencil->{X} ; delete $stencil->{Y} ; $stencil->{NAME} = $name; write_file($file_name, Dumper [$stencil]) ; } } } #----------------------------------------------------------------------------- sub serialize_self { my ($self, $indent) = @_ ; local $self->{widget} = undef ; local $self->{PIXMAP} = undef ; local $self->{ALLOCATED_COLORS} = undef ; local $self->{ACTIONS} = [] ; local $self->{HOOKS} = [] ; local $self->{CURRENT_ACTIONS} = [] ; local $self->{ACTIONS_BY_NAME} = [] ; local $self->{DO_STACK} = undef ; local $self->{IMPORT_EXPORT_HANDLERS} = undef ; local $self->{MODIFIED} => 0 ; local $self->{TITLE} = '' ; local $self->{CREATE_BACKUP} = undef ; local $self->{MIDDLE_BUTTON_SELECTION_FILTER} = undef ; local $Data::Dumper::Purity = 1 ; local $Data::Dumper::Indent = $indent || 0 ; local $Data::Dumper::Sortkeys = 1 ; Dumper($self) ; } #----------------------------------------------------------------------------- sub save_with_type { my ($self, $elements_to_save, $type, $file_name) = @_ ; my $title ; if ( exists $self->{IMPORT_EXPORT_HANDLERS}{$type}{EXPORT} && defined $self->{IMPORT_EXPORT_HANDLERS}{$type}{EXPORT} ) { $title = $self->{IMPORT_EXPORT_HANDLERS}{$type}{EXPORT}-> ( $self, $elements_to_save, $file_name, $self->{IMPORT_EXPORT_HANDLERS}{HANDLER_DATA}, ) ; } else { if($self->{CREATE_BACKUP} && -e $file_name) { use File::Copy; copy($file_name,"$file_name.bak") or die "save_with_type: Copy failed while making backup copy: $!"; } write_file($file_name,compress($self->serialize_self() .'$VAR1 ;')) ; $title = $file_name ; } return $title ; } #----------------------------------------------------------------------------- 1 ;App-Asciio-1.51.3/lib/App/Asciio/Setup.pm000444001750000144 2205212544473514 17460 0ustar00nadimusers000000000000 package App::Asciio ; $|++ ; use strict; use warnings; use Data::TreeDumper ; use Eval::Context ; use Carp ; use Module::Util qw(find_installed) ; use File::Basename ; #------------------------------------------------------------------------------------------------------ sub setup { my($self, $setup_ini_files) = @_ ; for my $setup_file (@{$setup_ini_files}) { print "Initializing with '$setup_file'\n" if $self->{DISPLAY_SETUP_INFORMATION}; unless(-e $setup_file) { croak "Can't find setup data '$setup_file'\n" ; } push @{$self->{SETUP_PATHS}}, $setup_file ; my ($setup_name, $setup_path, $setup_ext) = File::Basename::fileparse($setup_file, ('\..*')) ; my $ini_files ; { my $context = new Eval::Context() ; $ini_files = $context->eval ( PRE_CODE => "use strict;\nuse warnings;\n", CODE_FROM_FILE => $setup_file, ) ; die "can't load '$setup_file': $! $@\n" if $@ ; } $self->setup_stencils($setup_path, $ini_files->{STENCILS} || []) ; $self->setup_hooks($setup_path, $ini_files->{HOOK_FILES} || []) ; $self->setup_action_handlers($setup_path, $ini_files->{ACTION_FILES} || []) ; $self->setup_import_export_handlers($setup_path, $ini_files->{IMPORT_EXPORT} || []) ; $self->setup_object_options($setup_path, $ini_files->{ASCIIO_OBJECT_SETUP} || []) ; } } #------------------------------------------------------------------------------------------------------ sub setup_stencils { my($self, $setup_path, $stencils) = @_ ; for my $stencil (@{$stencils}) { if(-e "$setup_path/$stencil") { if(-f "$setup_path/$stencil") { print "loading stencil '$setup_path$stencil'\n" if $self->{DISPLAY_SETUP_INFORMATION} ; $self->load_elements("$setup_path/$stencil", $stencil) ; } elsif(-d "$setup_path/$stencil") { for(glob("$setup_path/$stencil/*")) { print "batch loading stencil '$setup_path/$stencil/$_'\n" if $self->{DISPLAY_SETUP_INFORMATION} ; $self->load_elements($_, $stencil) ; } } else { print "Unknown type '$setup_path/$stencil'!\n" ; } } else { print "Can't find '$setup_path/$stencil'!\n" ; } } } #------------------------------------------------------------------------------------------------------ my Readonly $CATEGORY = 0 ; my Readonly $SHORTCUTS = 0 ; my Readonly $CODE = 1 ; my Readonly $ARGUMENTS = 2 ; my Readonly $CONTEXT_MENUE_SUB = 3; my Readonly $CONTEXT_MENUE_ARGUMENTS = 4 ; my Readonly $NAME= 5 ; my Readonly $ORIGIN= 6 ; sub setup_hooks { my($self, $setup_path, $hook_files) = @_ ; for my $hook_file (@{ $hook_files }) { my $context = new Eval::Context() ; my @hooks ; $context->eval ( REMOVE_PACKAGE_AFTER_EVAL => 0, # VERY IMPORTANT as we return code references that will cease to exist otherwise INSTALL_SUBS => {register_hooks => sub{@hooks = @_}}, PRE_CODE => "use strict;\nuse warnings;\n", CODE_FROM_FILE => "$setup_path/$hook_file" , ) ; die "can't load hook file '$hook_file ': $! $@\n" if $@ ; for my $hook (@hooks) { $self->{HOOKS}{$hook->[$CATEGORY]} = $hook->[$CODE] ; } } } #------------------------------------------------------------------------------------------------------ sub setup_action_handlers { my($self, $setup_path, $action_files) = @_ ; for my $action_file (@{ $action_files }) { #~ print "setup_action_handlers: loading '$action_file'\n" ; my $context = new Eval::Context() ; #~ print "loading action '$setup_path$action_file'\n" ; my %action_handlers; $context->eval ( REMOVE_PACKAGE_AFTER_EVAL => 0, # VERY IMPORTANT as we return code references that will cease to exist otherwise INSTALL_SUBS => {register_action_handlers => sub{%action_handlers = @_}}, PRE_CODE => "use strict;\nuse warnings;\n", CODE_FROM_FILE => "$setup_path/$action_file", ) ; die "can't load setup file '$action_file': $! $@\n" if $@ ; for my $name (keys %action_handlers) { my $action_handler ; my $group_name ; my $shortcuts_definition ; if('HASH' eq ref $action_handlers{$name}) { $shortcuts_definition = $action_handlers{$name}{SHORTCUTS} ; $action_handlers{$name}{GROUP_NAME} = $group_name = $name ; $action_handlers{$name}{ORIGIN} = $action_file; $action_handler = $self->get_group_action_handler($action_handlers{$name}, $action_file) ; } elsif('ARRAY' eq ref $action_handlers{$name}) { $shortcuts_definition= $action_handlers{$name}[$SHORTCUTS] ; $action_handlers{$name}[$NAME] = $name ; $action_handlers{$name}[$ORIGIN] = $action_file ; $action_handler = $action_handlers{$name} ; } else { #~ print "ignoring '$name'\n" ; next ; } $self->{ACTIONS_BY_NAME}{$name} = $action_handlers{$name} ; my $shortcuts ; if('ARRAY' eq ref $shortcuts_definition) { $shortcuts = $shortcuts_definition ; } else { $shortcuts = [$shortcuts_definition] ; } for my $shortcut (@$shortcuts) { if(exists $self->{ACTIONS}{$shortcut}) { print "Overriding shortcut '$shortcut'!\n" ; print "\tnew is '$name' defined in file '$action_file'\n" ; print "\told was '$self->{ACTIONS}{$shortcut}[5]' defined in file '$self->{ACTIONS}{$shortcut}[6]'\n" ; } $self->{ACTIONS}{$shortcut} = $action_handler ; if(defined $group_name) { $self->{ACTIONS}{$shortcut}{GROUP_NAME} = $group_name ; $self->{ACTIONS}{$shortcut}{ORIGIN} = $action_file; } } } } } sub get_group_action_handler { my ($self, $action_handler_definition, $action_file) = @_ ; my %handler ; for my $name (keys %{$action_handler_definition}) { my $action_handler ; my $group_name ; my $shortcuts_definition ; if('SHORTCUTS' eq $name) { #~ print "Found shortcuts definition.\n" ; next ; } elsif('HASH' eq ref $action_handler_definition->{$name}) { $shortcuts_definition= $action_handler_definition->{$name}{SHORTCUTS} ; $action_handler_definition->{$name}{GROUP_NAME} = $group_name = $name ; $action_handler_definition->{$name}{ORIGIN} = $action_file ; $action_handler = $self->get_group_action_handler($action_handler_definition->{$name}, $action_file) ; } elsif('ARRAY' eq ref $action_handler_definition->{$name}) { $shortcuts_definition= $action_handler_definition->{$name}[$SHORTCUTS] ; $action_handler_definition->{$name}[$NAME] = $name ; $action_handler_definition->{$name}[$ORIGIN] = $action_file ; $action_handler = $action_handler_definition->{$name} ; } else { #~ print "ignoring '$name'\n" ; next ; } my $shortcuts ; if('ARRAY' eq ref $shortcuts_definition) { $shortcuts = $shortcuts_definition ; } else { $shortcuts = [$shortcuts_definition] ; } for my $shortcut (@$shortcuts) { if(exists $handler{$shortcut}) { print "Overriding action group '$shortcut' with definition from file'$action_file'!\n" ; } $handler{$shortcut} = $action_handler ; if(defined $group_name) { $handler{$shortcut}{GROUP_NAME} = $group_name ; } } } return \%handler ; } #------------------------------------------------------------------------------------------------------ sub setup_import_export_handlers { my($self, $setup_path, $import_export_files) = @_ ; for my $import_export_file (@{ $import_export_files }) { my $context = new Eval::Context() ; my %import_export_handlers ; $context->eval ( REMOVE_PACKAGE_AFTER_EVAL => 0, # VERY IMPORTANT as we return code references that will cease to exist otherwise INSTALL_SUBS => {register_import_export_handlers => sub{%import_export_handlers = @_}}, PRE_CODE => < "$setup_path/$import_export_file", ) ; die "can't load import/export handler defintion file '$import_export_file': $! $@\n" if $@ ; for my $extension (keys %import_export_handlers) { if(exists $self->{IMPORT_EXPORT_HANDLERS}{$extension}) { print "Overriding import/export handler for extension '$extension'!\n" ; } $self->{IMPORT_EXPORT_HANDLERS}{$extension} = $import_export_handlers{$extension} ; } } } #------------------------------------------------------------------------------------------------------ sub setup_object_options { my($self, $setup_path, $options_files) = @_ ; for my $options_file (@{ $options_files }) { my $context = new Eval::Context() ; my %options = $context->eval ( PRE_CODE => "use strict;\nuse warnings;\n", CODE_FROM_FILE => "$setup_path/$options_file", ) ; for my $option_name (keys %options) { $self->{$option_name} = $options{$option_name} ; } die "can't load setup file '$options_file': $! $@\n" if $@ ; } $self->event_options_changed() ; } #------------------------------------------------------------------------------------------------------ sub run_script { my($self, $script) = @_ ; if(defined $script) { my $context = new Eval::Context() ; $context->eval ( PRE_CODE => "use strict;\nuse warnings;\n", CODE_FROM_FILE => $script, INSTALL_VARIABLES => [ [ '$self' => $self => $Eval::Context::SHARED ], ] , ) ; die "can't load setup file '$script': $! $@\n" if $@ ; } } #------------------------------------------------------------------------------------------------------ 1 ; App-Asciio-1.51.3/lib/App/Asciio/Dialogs.pm000444001750000144 304712544473514 17725 0ustar00nadimusers000000000000 package App::Asciio ; $|++ ; use strict; use warnings; use Data::TreeDumper ; #----------------------------------------------------------------------------- sub get_color_from_user { my ($self, $previous_color) = @_ ; return [255, 0, 0] ; } #----------------------------------------------------------------------------- sub show_dump_window { my ($self, $data, $title, @dumper_setup) = @_ ; print DumpTree $data, $title, @dumper_setup ; } #----------------------------------------------------------------------------- sub display_message_modal { my ($self, $message) = @_ ; print $message ; } #----------------------------------------------------------------------------- sub display_yes_no_cancel_dialog { my ($self, $title, $text) = @_ ; print "$title\n$text\n" ; print "Yes/No/Cancel\n" ; my $answer = ; chomp ($answer) ; return $answer ; } #----------------------------------------------------------------------------- sub display_quit_dialog { my ($self, $title, $text) = @_ ; print "$title\n$text\n" ; print "Yes/No/Cancel\n" ; my $answer = ; chomp ($answer) ; return $answer ; } sub display_edit_dialog { my ($self, $title, $text) = @_ ; print "$title\n$text\n" ; my $answer = ; chomp ($answer) ; return $answer ; } #----------------------------------------------------------------------------- sub get_file_name { my ($self, $type) = @_ ; print "get_file_name:\n" ; my $answer = ; chomp ($answer) ; return $answer ; } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.51.3/lib/App/Asciio/Elements.pm000444001750000144 4146012544473514 20140 0ustar00nadimusers000000000000 package App::Asciio ; $|++ ; use strict; use warnings; use Carp ; use Data::Dumper ; use Data::TreeDumper ; use File::Slurp ; use Clone; use List::Util qw(min max) ; use List::MoreUtils qw(any minmax first_value) ; use Readonly ; use App::Asciio::Connections ; #----------------------------------------------------------------------------- sub set_modified_state { my ($self, $state) = @_ ; $self->{MODIFIED} = $state ; } #----------------------------------------------------------------------------- sub get_modified_state { my ($self) = @_ ; $self->{MODIFIED} ; } #----------------------------------------------------------------------------- sub get_group_color { # cycle through color to give visual clue to user my ($self) = @_ ; my $name = $self->{GROUP_COLORS}[$self->{NEXT_GROUP_COLOR}] ; $self->{NEXT_GROUP_COLOR}++ ; $self->{NEXT_GROUP_COLOR} = 0 if $self->{NEXT_GROUP_COLOR} >= scalar(@{$self->{GROUP_COLORS}}) ; return ($name) ; } #----------------------------------------------------------------------------- sub add_ruler_lines { my ($self, @lines) = @_ ; push @{$self->{RULER_LINES}}, @lines ; $self->{MODIFIED }++ ; } sub remove_ruler_lines { my ($self, @ruler_lines_to_remove) = @_ ; my %removed ; for my $ruler_line_to_remove (@ruler_lines_to_remove) { for my $ruler_line (@{$self->{RULER_LINES}}) { if ( $ruler_line->{TYPE} eq $ruler_line_to_remove->{TYPE} && $ruler_line->{POSITION} == $ruler_line_to_remove->{POSITION} ) { $removed{$ruler_line} ++ ; } } } $self->{RULER_LINES} = [grep {! exists $removed{$_}} @{$self->{RULER_LINES}} ] ; } sub exists_ruler_line { my ($self, @ruler_lines_to_check) = @_ ; my $exists = 0 ; for my $ruler_line_to_check (@ruler_lines_to_check) { for my $ruler_line (@{$self->{RULER_LINES}}) { if ( $ruler_line->{TYPE} eq $ruler_line_to_check->{TYPE} && $ruler_line->{POSITION} == $ruler_line_to_check->{POSITION} ) { $exists++ ; last ; } } } return $exists ; } #----------------------------------------------------------------------------- sub add_new_element_named { my ($self, $element_name, $x, $y) = @_ ; my $element_index = $self->{ELEMENT_TYPES_BY_NAME}{$element_name} ; if(defined $element_index) { return add_new_element_of_type($self, $self->{ELEMENT_TYPES}[$element_index], $x, $y) ; } else { croak "add_new_element_named: can't create element named '$element_name'!\n" ; } } #----------------------------------------------------------------------------- sub add_new_element_of_type { my ($self, $element, $x, $y) = @_ ; my $new_element = Clone::clone($element) ; @$new_element{'X', 'Y', 'SELECTED'} = ($x, $y, 0) ; $self->add_elements($new_element) ; return($new_element) ; } #----------------------------------------------------------------------------- sub set_element_position { my ($self, $element, $x, $y) = @_ ; @$element{'X', 'Y'} = ($x, $y) ; } #----------------------------------------------------------------------------- sub add_element_at { my ($self, $element, $x, $y) = @_ ; $self->add_element_at_no_connection($element,$x, $y) ; $self->connect_elements($element) ; } sub add_element_at_no_connection { my ($self, $element, $x, $y) = @_ ; $self->set_element_position($element,$x, $y) ; $self->add_elements_no_connection($element) ; } #----------------------------------------------------------------------------- sub add_elements { my ($self, @elements) = @_ ; $self->add_elements_no_connection(@elements) ; $self->connect_elements(@elements) ; } sub add_elements_no_connection { my ($self, @elements) = @_ ; push @{$self->{ELEMENTS}}, @elements ; $self->{MODIFIED }++ ; } #----------------------------------------------------------------------------- sub unshift_elements { my ($self, @elements) = @_ ; unshift @{$self->{ELEMENTS}}, @elements ; $self->{MODIFIED }++ ; } #----------------------------------------------------------------------------- sub move_elements { my ($self, $x_offset, $y_offset, @elements) = @_ ; my %selected_elements = map { $_ => 1} @elements ; for my $element (@elements) { @$element{'X', 'Y'} = ($element->{X} + $x_offset, $element->{Y} + $y_offset) ; # handle arrow element my (@current_element_connections, %used_connectors) ; if($self->is_connected($element)) { # disconnect current connections if it is not connected to another elements we are moving # connectees move their connected along @current_element_connections =$self->get_connections_containing($element) , my (@connections_to_delete, @connections_to_keep) ; for my $current_element_connection (@current_element_connections) { if(exists $selected_elements{$current_element_connection->{CONNECTEE}}) { $used_connectors{$current_element_connection->{CONNECTOR}{NAME}}++ ; push @connections_to_keep, $current_element_connection ; } else { push @connections_to_delete, $current_element_connection ; } } $self->delete_connections(@connections_to_delete) ; @current_element_connections = @connections_to_keep ; } # connect to new elements if the connection doesn't already exist # and connection not already done with one of the elements being moved my @new_connections = grep { # connector already used to connect to a moved element ! exists $used_connectors{$_->{CONNECTOR}{NAME}} } grep { # connection to that element already exists, don't reconnect to moved element ! exists $selected_elements{$_->{CONNECTEE}} } $self->get_possible_connections($element) ; $self->add_connections(@new_connections) ; # handle box element for my $connection ($self->get_connected($element)) { # move connected with connectees if (exists $selected_elements{$connection->{CONNECTED}}) { # arrow is part of the selection being moved } else { my ($x_offset, $y_offset, $width, $height, $new_connector) = $connection->{CONNECTED}->move_connector ( $connection->{CONNECTOR}{NAME}, $x_offset, $y_offset ) ; $connection->{CONNECTED}{X} += $x_offset ; $connection->{CONNECTED}{Y} += $y_offset; # the connection point has also changed $connection->{CONNECTOR} = $new_connector ; $connection->{FIXED}++ ; #find the other connectors belonging to this connected for my $other_connection (grep{ ! $_->{FIXED}} @{$self->{CONNECTIONS}}) { # move them relatively to their previous position if($connection->{CONNECTED} == $other_connection->{CONNECTED}) { my ($new_connector) = # in characters relative to element origin $other_connection->{CONNECTED}->get_named_connection($other_connection->{CONNECTOR}{NAME}) ; $other_connection->{CONNECTOR} = $new_connector ; $other_connection->{FIXED}++ ; } } } } for my $connection (@{$self->{CONNECTIONS}}) { delete $connection->{FIXED} ; } $self->{MODIFIED }++ ; } } #----------------------------------------------------------------------------- sub resize_element { my ($self, $reference_x, $reference_y, $new_x, $new_y, $selected_element, $connector_name) = @ _; my ($x_offset, $y_offset, undef, undef, $resized_connector_name) = $selected_element->resize($reference_x, $reference_y, $new_x, $new_y, undef, $connector_name) ; $selected_element->{X} += $x_offset ; $selected_element->{Y} += $y_offset; # handle connections if($self->is_connected($selected_element)) { # disconnect current connections $self->delete_connections_containing($selected_element) ; } $self->connect_elements($selected_element) ; # connect to new elements if any for my $connection ($self->get_connected($selected_element)) { # all connection where the selected element is the connectee my ($new_connection) = # in characters relative to element origin $selected_element->get_named_connection($connection->{CONNECTION}{NAME}) ; if(defined $new_connection) { my ($x_offset, $y_offset, $width, $height, $new_connector) = $connection->{CONNECTED}->move_connector ( $connection->{CONNECTOR}{NAME}, $new_connection->{X} - $connection->{CONNECTION}{X}, $new_connection->{Y}- $connection->{CONNECTION}{Y} ) ; $connection->{CONNECTED}{X} += $x_offset ; $connection->{CONNECTED}{Y} += $y_offset ; # the connection point has also changed $connection->{CONNECTOR} = $new_connector ; $connection->{CONNECTION} = $new_connection ; $connection->{FIXED}++ ; #find the other connectors belonging to this connected for my $other_connection (grep{ ! $_->{FIXED}} @{$self->{CONNECTIONS}}) { # move them relatively to their previous position if($connection->{CONNECTED} == $other_connection->{CONNECTED}) { my ($new_connector) = # in characters relative to element origin $other_connection->{CONNECTED}->get_named_connection($other_connection->{CONNECTOR}{NAME}) ; $other_connection->{CONNECTOR} = $new_connector ; $other_connection->{FIXED}++ ; } } for my $connection (@{$self->{CONNECTIONS}}) { delete $connection->{FIXED} ; } } else { $self->delete_connections($connection) ; } } return($x_offset, $y_offset, $resized_connector_name) ; } #----------------------------------------------------------------------------- sub move_elements_to_front { my ($self, @elements) = @_ ; my %elements_to_move = map {$_ => 1} @elements ; my @new_element_list ; for(@{$self->{ELEMENTS}}) { push @new_element_list, $_ unless (exists $elements_to_move{$_}) ; } $self->{ELEMENTS} = [@new_element_list, @elements] ; } ; #---------------------------------------------------------------------------------------------- sub move_elements_to_back { my ($self, @elements) = @_ ; my %elements_to_move = map {$_ => 1} @elements ; my @new_element_list ; for(@{$self->{ELEMENTS}}) { push @new_element_list, $_ unless (exists $elements_to_move{$_}) ; } $self->{ELEMENTS} = [@elements, @new_element_list] ; } ; #----------------------------------------------------------------------------- sub delete_elements { my($self, @elements) = @_ ; my %elements_to_delete = map {$_, 1} @elements ; for my $element (@{$self->{ELEMENTS}}) { if(exists $elements_to_delete{$element}) { $self->delete_connections_containing($element) ; $element = undef ; } } @{$self->{ELEMENTS}} = grep { defined $_} @{$self->{ELEMENTS}} ; $self->{MODIFIED }++ ; } #----------------------------------------------------------------------------- sub edit_element { my ($self, $selected_element) = @_ ; $selected_element->edit($self) ; # handle connections if($self->is_connected($selected_element)) { # disconnect current connections $self->delete_connections_containing($selected_element) ; } #~ !!! TODO if not already connected to them (same connection) $self->connect_elements($selected_element) ; # connect to new elements if any for my $connection ($self->get_connected($selected_element)) { # all connection where the selected element is the connectee my ($new_connection) = # in characters relative to element origin $selected_element->get_named_connection($connection->{CONNECTION}{NAME}) ; if(defined $new_connection) { my ($x_offset, $y_offset, $width, $height, $new_connector) = $connection->{CONNECTED}->move_connector ( $connection->{CONNECTOR}{NAME}, $new_connection->{X} - $connection->{CONNECTION}{X}, $new_connection->{Y}- $connection->{CONNECTION}{Y} ) ; $connection->{CONNECTED}{X} += $x_offset ; $connection->{CONNECTED}{Y} += $y_offset; # the connection point has also changed $connection->{CONNECTOR} = $new_connector ; $connection->{CONNECTION} = $new_connection ; $connection->{FIXED}++ ; #find the other connectors belonging to this connected for my $other_connection (grep{ ! $_->{FIXED}} @{$self->{CONNECTIONS}}) { # move them relatively to their previous position if($connection->{CONNECTED} == $other_connection->{CONNECTED}) { my ($new_connector) = # in characters relative to element origin $other_connection->{CONNECTED}->get_named_connection($other_connection->{CONNECTOR}{NAME}) ; $other_connection->{CONNECTOR} = $new_connector ; $other_connection->{FIXED}++ ; } } for my $connection (@{$self->{CONNECTIONS}}) { delete $connection->{FIXED} ; } } else { $self->delete_connections($connection) ; } #~ TODO fix the other connection as move does above } $self->{MODIFIED }++ ; } #----------------------------------------------------------------------------- sub get_selected_elements { my ($self, $state) = @_ ; return ( grep { if($state) { exists $_->{SELECTED} && $_->{SELECTED} != 0 } else { ! exists $_->{SELECTED} || $_->{SELECTED} == 0 } } @{$self->{ELEMENTS}} ) ; } #----------------------------------------------------------------------------- sub any_select_elements { my ($self) = @_ ; return(any {$_->{SELECTED}} @{$self->{ELEMENTS}}) ; } #----------------------------------------------------------------------------- sub select_elements { my ($self, $state, @elements) = @_ ; my %groups_to_select ; for my $element (@elements) { if($state) { $element->{SELECTED} = ++$self->{SELECTION_INDEX} ; } else { $element->{SELECTED} = 0 ; } if(exists $element->{GROUP} && defined $element->{GROUP}[-1]) { $groups_to_select{$element->{GROUP}[-1]}++ ; } } # select groups for my $element (@{$self->{ELEMENTS}}) { if ( exists $element->{GROUP} && defined $element->{GROUP}[-1] && exists $groups_to_select{$element->{GROUP}[-1]} ) { if($state) { $element->{SELECTED} = ++$self->{SELECTION_INDEX} ; } else { $element->{SELECTED} = 0 ; } } } delete $self->{SELECTION_INDEX} unless $self->get_selected_elements(1) ; } #----------------------------------------------------------------------------- sub select_all_elements { my ($self) = @_ ; $self->select_elements(1, @{$self->{ELEMENTS}}) ; } #----------------------------------------------------------------------------- sub deselect_all_elements { my ($self) = @_ ; $self->select_elements(0, @{$self->{ELEMENTS}}) ; } #----------------------------------------------------------------------------- sub select_elements_flip { my ($self, @elements) = @_ ; for my $element (@elements) { $self->select_elements($element->{SELECTED} ? 0 : 1, $element) ; } delete $self->{SELECTION_INDEX} unless $self->get_selected_elements(1) ; } #----------------------------------------------------------------------------- sub is_element_selected { my ($self, $element) = @_ ; $element->{SELECTED} ; } #----------------------------------------------------------------------------- sub is_over_element { my ($self, $element, $x, $y, $field) = @_ ; die "Error: 'is_over_element' needs position!" unless defined $x && defined $y ; $field ||= 0 ; my $is_under = 0 ; for my $mask_strip ($element->get_mask_and_element_stripes()) { my $stripe_x = $element->{X} + $mask_strip->{X_OFFSET} ; my $stripe_y = $element->{Y} + $mask_strip->{Y_OFFSET} ; if ( $stripe_x - $field <= $x && $x < $stripe_x + $mask_strip->{WIDTH} + $field && $stripe_y - $field <= $y && $y < $stripe_y + $mask_strip->{HEIGHT} + $field ) { $is_under++ ; last ; } } return($is_under) ; } #----------------------------------------------------------------------------- sub element_completely_within_rectangle { my ($self, $element, $rectangle) = @_ ; my ($start_x, $start_y) = ($rectangle->{START_X}, $rectangle->{START_Y}) ; my $width = $rectangle->{END_X} - $rectangle->{START_X} ; my $height = $rectangle->{END_Y} - $rectangle->{START_Y}; if($width < 0) { $width *= -1 ; $start_x -= $width ; } if($height < 0) { $height *= -1 ; $start_y -= $height ; } my $is_under = 1 ; for my $mask_strip ($element->get_mask_and_element_stripes()) { my $stripe_x = $element->{X} + $mask_strip->{X_OFFSET} ; my $stripe_y = $element->{Y} + $mask_strip->{Y_OFFSET} ; if ( $start_x <= $stripe_x && ($stripe_x + $mask_strip->{WIDTH}) <= $start_x +$width && $start_y <= $stripe_y && ($stripe_y + $mask_strip->{HEIGHT}) <= $start_y + $height ) { } else { $is_under = 0 ; last } } return($is_under) ; } #----------------------------------------------------------------------------- sub pixel_to_character_x { my ($self, @pixels) = @_ ; my ($character_width, $character_height) = $self->get_character_size() ; map {int($_ / $character_width)} @pixels ; } sub pixel_to_character_y { my ($self, @pixels) = @_ ; my ($character_width, $character_height) = $self->get_character_size() ; map {int($_ / $character_height)} @pixels ; } #----------------------------------------------------------------------------- sub closest_character { my ($self, $x, $y) = @_ ; my ($character_width, $character_height) = $self->get_character_size() ; my $character_x = int($x / $character_width) ; my $character_y = int($y / $character_height) ; return($character_x, $character_y) ; } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.51.3/lib/App/Asciio/stripes000755001750000144 012544473514 17335 5ustar00nadimusers000000000000App-Asciio-1.51.3/lib/App/Asciio/stripes/wirl_arrow.pm000444001750000144 4106512544473514 22245 0ustar00nadimusers000000000000 package App::Asciio::stripes::wirl_arrow ; use base App::Asciio::stripes::stripes ; use strict; use warnings; use List::Util qw(min max) ; use Readonly ; use Clone ; #----------------------------------------------------------------------------- Readonly my $DEFAULT_ARROW_TYPE => [ #name: $start, $body, $connection, $body_2, $end ['origin', '', '*', '', '', '', 1], ['up', '|', '|', '', '', '^', 1], ['down', '|', '|', '', '', 'v', 1], ['left', '-', '-', '', '', '<', 1], ['upleft', '|', '|', '.', '-', '<', 1], ['leftup', '-', '-', '\'', '|', '^', 1], ['downleft', '|', '|', '\'', '-', '<', 1], ['leftdown', '-', '-', '.', '|', 'v', 1], ['right', '-', '-','', '', '>', 1], ['upright', '|', '|', '.', '-', '>', 1], ['rightup', '-', '-', '\'', '|', '^', 1], ['downright', '|', '|', '\'', '-', '>', 1], ['rightdown', '-', '-', '.', '|', 'v', 1], ['45', '/', '/', '', '', '^', 1, ], ['135', '\\', '\\', '', '', 'v', 1, ], ['225', '/', '/', '', '', 'v', 1, ], ['315', '\\', '\\', '', '', '^', 1, ], ] ; sub new { my ($class, $element_definition) = @_ ; my $self = bless {}, __PACKAGE__ ; $self->setup ( $element_definition->{ARROW_TYPE} || Clone::clone($DEFAULT_ARROW_TYPE), $element_definition->{END_X}, $element_definition->{END_Y}, $element_definition->{DIRECTION}, $element_definition->{ALLOW_DIAGONAL_LINES}, $element_definition->{EDITABLE}, ) ; return $self ; } #----------------------------------------------------------------------------- sub setup { my ($self, $arrow_type, $end_x, $end_y, $direction, $allow_diagonal_lines, $editable) = @_ ; my ($stripes, $width, $height) ; ($stripes, $width, $height, $direction) = get_arrow($arrow_type, $end_x, $end_y, $direction, $allow_diagonal_lines) ; $self->set ( STRIPES => $stripes, WIDTH => $width, HEIGHT => $height, DIRECTION => $direction, ARROW_TYPE => $arrow_type, END_X => $end_x, END_Y => $end_y, ALLOW_DIAGONAL_LINES => $allow_diagonal_lines, ) ; } #----------------------------------------------------------------------------- my %direction_to_arrow = ( 'origin' => \&draw_origin, 'up' => \&draw_up, 'down' => \&draw_down, 'left' => \&draw_left, 'up-left' => \&draw_upleft, 'left-up' => \&draw_leftup, 'down-left' => \&draw_downleft, 'left-down' => \&draw_leftdown, 'right' => \&draw_right, 'up-right' => \&draw_upright, 'right-up' => \&draw_rightup, 'down-right' => \&draw_downright, 'right-down' => \&draw_rightdown, ) ; sub get_arrow { my ($arrow_type, $end_x, $end_y, $direction, $allow_diagonal_lines) = @_ ; use constant CENTER => 1 ; use constant LEFT => 0 ; use constant RIGHT => 2 ; use constant UP => 0 ; use constant DOWN => 2 ; my @position_to_direction = ( [$direction =~ /^up/ ? 'up-left' : 'left-up', 'left', $direction =~ /^down/ ? 'down-left' : 'left-down'] , ['up', 'origin', 'down'], [$direction =~ /^up/ ? 'up-right' : 'right-up', 'right', $direction =~ /^down/ ? 'down-right' : 'right-down'], ) ; $direction = $position_to_direction [$end_x == 0 ? CENTER : $end_x < 0 ? LEFT : RIGHT] [$end_y == 0 ? CENTER : $end_y < 0 ? UP : DOWN] ; return($direction_to_arrow{$direction}->($arrow_type, $end_x, $end_y, $allow_diagonal_lines), $direction) ; } sub draw_down { my ($arrow_type, $end_x, $end_y) = @_ ; my ($stripes, $width, $height) = ([], 1, $end_y + 1) ; my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[2]}[1 .. 5] ; push @{$stripes}, { 'HEIGHT' => $height, 'TEXT' => $height == 2 ? "$start\n$end" : $start . "\n" . ("$body\n" x ($height -2)) . $end, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; return($stripes, $width, $height) ; } sub draw_origin { my ($arrow_type, $end_x, $end_y) = @_ ; my ($stripes, $width, $height) = ([], 1, 1) ; my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[0]}[1 .. 5] ; push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; return($stripes, $width, $height) ; } sub draw_up { my ($arrow_type, $end_x, $end_y) = @_ ; my ($stripes, $width, $height) = ([], 1, -$end_y + 1) ; my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[1]}[1 .. 5] ; push @{$stripes}, { 'HEIGHT' => $height, 'TEXT' => $height == 2 ? "$end\n$start" : $end . "\n" . ("$body\n" x ($height -2)) . $start, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => $end_y, }; return($stripes, $width, $height) ; } sub draw_left { my ($arrow_type, $end_x, $end_y) = @_ ; my ($stripes, $width, $height) = ([], -$end_x + 1, 1) ; my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[3]}[1 .. 5] ; push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $width == 2 ? "$end$start" : $end . $body x ($width -2) . $start, 'WIDTH' => $width, 'X_OFFSET' => $end_x, 'Y_OFFSET' => 0, }; return($stripes, $width, $height) ; } sub draw_upleft # or 315 { my ($arrow_type, $end_x, $end_y, $allow_diagonal_lines) = @_ ; my ($stripes, $width, $height) = ([], -$end_x + 1, -$end_y + 1) ; if($allow_diagonal_lines && $end_x == $end_y) { my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[16]}[1 .. 5] ; push @{$stripes}, get_315_stripes($end_x, $start, $body, $end) ; } else { my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[4]}[1 .. 5] ; push @{$stripes}, { 'HEIGHT' => $height , 'TEXT' => "$connection\n" . "$body\n" x ($height - 2) . $start, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => $end_y, }, { 'HEIGHT' => 1, 'TEXT' => $end . $body_2 x ($width - 2), 'WIDTH' => $width - 1, 'X_OFFSET' => $end_x, 'Y_OFFSET' => $end_y , }; } return($stripes, $width, $height) ; } sub draw_leftup # or 315 { my ($arrow_type, $end_x, $end_y, $allow_diagonal_lines) = @_ ; my ($stripes, $width, $height) = ([], -$end_x + 1, -$end_y + 1) ; my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[5]}[1 .. 5] ; if($allow_diagonal_lines && $end_x == $end_y) { my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[16]}[1 .. 5] ; push @{$stripes}, get_315_stripes($end_x, $start, $body, $end) ; } else { push @{$stripes}, { 'HEIGHT' => 1 , 'TEXT' => $connection . $body x ($width - 2) . $start, 'WIDTH' => $width, 'X_OFFSET' => $end_x, 'Y_OFFSET' => 0, }, { 'HEIGHT' => $height - 1, 'TEXT' => "$end\n" . "$body_2\n" x ($height - 2), 'WIDTH' => 1, 'X_OFFSET' => $end_x, 'Y_OFFSET' => $end_y , }; } return($stripes, $width, $height) ; } sub get_315_stripes { my ($position, $start, $body, $end) = @_ ; my @stripes ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; for(my $xy = -$position - 1 ; $xy> 0 ; $xy--) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => -$xy, 'Y_OFFSET' => -$xy, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => $position , 'Y_OFFSET' => $position , }; return(@stripes) ; } sub draw_downleft # or 225 { my ($arrow_type, $end_x, $end_y, $allow_diagonal_lines) = @_ ; my ($stripes, $width, $height) = ([], -$end_x + 1, $end_y + 1) ; my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[6]}[1 .. 5] ; if($allow_diagonal_lines && -$end_x == $end_y) { my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[15]}[1 .. 5] ; push @{$stripes}, get_225_stripes($end_x, $start, $body, $end) ; } else { push @{$stripes}, { 'HEIGHT' => $height , 'TEXT' => "$start\n" . "$body\n" x ($height - 2) . $connection, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }, { 'HEIGHT' => 1, 'TEXT' => $end . $body_2 x ($width - 2), 'WIDTH' => $width - 1, 'X_OFFSET' => $end_x, 'Y_OFFSET' => $end_y , }; } return($stripes, $width, $height) ; } sub draw_leftdown # or 225 { my ($arrow_type, $end_x, $end_y, $allow_diagonal_lines) = @_ ; my ($stripes, $width, $height) = ([], -$end_x + 1, $end_y + 1) ; my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[7]}[1 .. 5] ; if($allow_diagonal_lines && -$end_x == $end_y) { my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[15]}[1 .. 5] ; push @{$stripes}, get_225_stripes($end_x, $start, $body, $end) ; } else { push @{$stripes}, { 'HEIGHT' => 1 , 'TEXT' => $connection . $body x ($width - 2) . $start, 'WIDTH' => $width, 'X_OFFSET' => $end_x, 'Y_OFFSET' => 0, }, { 'HEIGHT' => $height - 1, 'TEXT' => "$body_2\n" x ($height - 2) . $end, 'WIDTH' => 1, 'X_OFFSET' => $end_x, 'Y_OFFSET' => 1 , }; } return($stripes, $width, $height) ; } sub get_225_stripes { my ($position, $start, $body, $end) = @_ ; my @stripes ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; for(my $xy = -$position - 1 ; $xy> 0 ; $xy--) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => -$xy, 'Y_OFFSET' => $xy, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => $position , 'Y_OFFSET' => -$position , }; return(@stripes) ; } sub draw_right { my ($arrow_type, $end_x, $end_y) = @_ ; my ($stripes, $width, $height) = ([], $end_x + 1, 1) ; my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[8]}[1 .. 5] ; push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $width == 2 ? "$start$end" : $start . $body x ($width -2) . $end, 'WIDTH' => $width, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; return($stripes, $width, $height) ; } sub draw_upright # or 45 { my ($arrow_type, $end_x, $end_y, $allow_diagonal_lines) = @_ ; my ($stripes, $width, $height) = ([], $end_x + 1, -$end_y + 1) ; my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[9]}[1 .. 5] ; if($allow_diagonal_lines && -$end_x == $end_y) { my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[13]}[1 .. 5] ; push @{$stripes}, get_45_stripes($end_x, $start, $body, $end) ; } else { push @{$stripes}, { 'HEIGHT' => $height , 'TEXT' => "$connection\n". "$body\n" x ($height -2) . $start, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => $end_y, }, { 'HEIGHT' => 1, 'TEXT' => $body_2 x ($width -2) . $end, 'WIDTH' => $end_x, 'X_OFFSET' => 1, 'Y_OFFSET' => $end_y, }; } return($stripes, $width, $height) ; } sub draw_rightup # or 45 { my ($arrow_type, $end_x, $end_y, $allow_diagonal_lines) = @_ ; my ($stripes, $width, $height) = ([], $end_x + 1, -$end_y + 1) ; my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[10]}[1 .. 5] ; if($allow_diagonal_lines && -$end_x == $end_y) { my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[13]}[1 .. 5] ; push @{$stripes}, get_45_stripes($end_x, $start, $body, $end) ; } else { push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $start . $body x ($width -2) . $connection, 'WIDTH' => $width, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }, { 'HEIGHT' => $height - 1, 'TEXT' => "$end\n" . "$body_2\n" x ($height -2), 'WIDTH' => 1, 'X_OFFSET' => $end_x, 'Y_OFFSET' => $end_y, }; } return($stripes, $width, $height) ; } sub get_45_stripes { my ($position, $start, $body, $end) = @_ ; my @stripes ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; for(my $xy = $position - 1 ; $xy > 0 ; $xy--) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => $xy, 'Y_OFFSET' => -$xy, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => $position , 'Y_OFFSET' => -$position , }; return(@stripes) ; } sub draw_downright # or 135 { my ($arrow_type, $end_x, $end_y, $allow_diagonal_lines) = @_ ; my ($stripes, $width, $height) = ([], $end_x + 1, $end_y + 1) ; my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[11]}[1 .. 5] ; if($allow_diagonal_lines && $end_x == $end_y) { my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[14]}[1 .. 5] ; push @{$stripes}, get_135_stripes($end_x, $start, $body, $end) ; } else { push @{$stripes}, { 'HEIGHT' => $height , 'TEXT' => "$start\n" ."$body\n" x ($height -2) . $connection, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }, { 'HEIGHT' => 1, 'TEXT' => $body_2 x ($width -2) . $end, 'WIDTH' => $width - 1, 'X_OFFSET' => 1, 'Y_OFFSET' => $end_y, }; } return($stripes, $width, $height) ; } sub draw_rightdown # or 135 { my ($arrow_type, $end_x, $end_y, $allow_diagonal_lines) = @_ ; my ($stripes, $width, $height) = ([], $end_x + 1, $end_y + 1) ; my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[12]}[1 .. 5] ; if($allow_diagonal_lines && $end_x == $end_y) { my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[14]}[1 .. 5] ; push @{$stripes}, get_135_stripes($end_x, $start, $body, $end) ; } else { push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $start . $body x ($width -2) . $connection, 'WIDTH' => $width, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }, { 'HEIGHT' => $height - 1 , 'TEXT' => "$body_2\n" x ($height -2) . $end, 'WIDTH' => 1, 'X_OFFSET' => $end_x, 'Y_OFFSET' => 1, }; } return($stripes, $width, $height) ; } sub get_135_stripes { my ($position, $start, $body, $end) = @_ ; my @stripes ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => 0 , 'Y_OFFSET' => 0 , }; for(my $xy = 1 ; $xy < $position ; $xy++) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => $xy, 'Y_OFFSET' => $xy, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => $position, 'Y_OFFSET' => $position, }; return(@stripes) ; } #----------------------------------------------------------------------------- sub get_selection_action { my ($self, $x, $y) = @_ ; if ( ($x == 0 && $y == 0) || ($x == $self->{END_X} && $y == $self->{END_Y}) ) { 'resize' ; } else { 'move' ; } } #----------------------------------------------------------------------------- sub get_connector_points { my ($self) = @_ ; return ( {X => 0, Y => 0, NAME => 'start'}, {X => $self->{END_X}, Y => $self->{END_Y}, NAME => 'end'}, ) ; } #----------------------------------------------------------------------------- sub get_named_connection { my ($self, $name) = @_ ; if($name eq 'start') { return( {X => 0, Y => 0, NAME => 'start'} ) ; } elsif($name eq 'end') { return( {X => $self->{END_X}, Y => $self->{END_Y}, NAME => 'end'} ) ; } else { return ; } } #----------------------------------------------------------------------------- sub get_direction { my ($self) = @_ ; return $self->{DIRECTION} ; } #----------------------------------------------------------------------------- sub move_connector { my ($self, $connector_name, $x_offset, $y_offset, $hint) = @_ ; if($connector_name eq 'start') { my ($x_offset, $y_offset, $width, $height, undef) = $self->resize(0, 0, $x_offset, $y_offset, $hint) ; return $x_offset, $y_offset, $width, $height, {X => $self->{END_X}, Y => $self->{END_Y}, NAME => 'start'} ; } elsif($connector_name eq 'end') { my ($x_offset, $y_offset, $width, $height, undef) = $self->resize(-1, -1, $self->{END_X} + $x_offset, $self->{END_Y} + $y_offset, $hint) ; return $x_offset, $y_offset, $width, $height, {X => $self->{END_X}, Y => $self->{END_Y}, NAME => 'end'} ; } else { die "unknown connector '$connector_name'!\n" ; } } #----------------------------------------------------------------------------- sub resize { my ($self, $reference_x, $reference_y, $new_x, $new_y, $hint, $connector_name) = @_ ; my $is_start ; if(defined $connector_name) { if($connector_name eq 'start') { $is_start++ ; } } else { if($reference_x == 0 && $reference_y == 0) { $is_start++ ; } } if($is_start) { my $x_offset = $new_x ; my $y_offset = $new_y ; my $new_end_x = $self->{END_X} - $x_offset ; my $new_end_y = $self->{END_Y} - $y_offset ; $self->setup($self->{ARROW_TYPE}, $new_end_x, $new_end_y, $hint || $self->{DIRECTION},$self ->{ALLOW_DIAGONAL_LINES}, $self->{EDITABLE}) ; return($x_offset, $y_offset, $self->{WIDTH}, $self->{HEIGHT}, 'start') ; } else { my $new_end_x = $new_x ; my $new_end_y = $new_y ; $self->setup($self->{ARROW_TYPE}, $new_end_x, $new_end_y, $hint || $self->{DIRECTION}, $self ->{ALLOW_DIAGONAL_LINES}, $self->{EDITABLE}) ; return(0, 0, $self->{WIDTH}, $self->{HEIGHT}, 'end') ; } } #----------------------------------------------------------------------------- sub edit { my ($self, $asciio) = @_ ; return unless $self->{EDITABLE} ; $self->display_arrow_edit_dialog() ; my ($stripes, $width, $height, $x_offset, $y_offset) = $direction_to_arrow{$self->{DIRECTION}}->($self->{ARROW_TYPE}, $self->{END_X}, $self->{END_Y}) ; $self->set(STRIPES => $stripes,) ; } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.51.3/lib/App/Asciio/stripes/single_stripe.pm000444001750000144 306712544473514 22705 0ustar00nadimusers000000000000 package App::Asciio::stripes::single_stripe ; use base App::Asciio::stripes::stripes ; use strict; use warnings; sub new { my ($class, $element_definition) = @_ ; my $self = bless {}, __PACKAGE__ ; $self->setup($element_definition->{TEXT}) ; return($self) ; } #----------------------------------------------------------------------------- sub setup { my ($self, $text) = @_ ; my $width = 0 ; map {$width = $width < length($_) ? length($_) : $width} split("\n", $text) ; my $height = ($text =~ tr[\n][\n]) + 1 ; $self->set ( TEXT => $text, WIDTH => $width, HEIGHT => $height, ) ; } #----------------------------------------------------------------------------- sub get_mask_and_element_stripes { my ($self) = @_ ; return {X_OFFSET => 0, Y_OFFSET => 0, WIDTH => $self->{WIDTH}, HEIGHT => $self->{HEIGHT}, TEXT => $self->{TEXT}} ; } #----------------------------------------------------------------------------- sub get_size { my ($self) = @_ ; return($self->{WIDTH}, $self->{HEIGHT}) ; } #----------------------------------------------------------------------------- sub resize { my ($self, $reference_x, $reference_y, $new_x, $new_y) = @_ ; return(0, 0, $self->{WIDTH}, $self->{HEIGHT}) ; } #----------------------------------------------------------------------------- sub get_text { my ($self) = @_ ; return($self->{TEXT}) ; } #----------------------------------------------------------------------------- sub set_text { my ($self, $text) = @_ ; $self->setup($text) ; } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.51.3/lib/App/Asciio/stripes/angled_arrow.pm000444001750000144 6645112544473514 22530 0ustar00nadimusers000000000000 package App::Asciio::stripes::angled_arrow ; use base App::Asciio::stripes::stripes ; use strict; use warnings; use List::Util qw(min max) ; use Readonly ; #----------------------------------------------------------------------------- Readonly my $DEFAULT_GLYPHS=> #name: => [$start, $body, $connection, $body_2, $end, $vertical, $diagonal_connection] { 'origin' => [ '*', '?', '?', '?', '?', '?', '?'], 'up'=> [ "'", '|', '?', '?', '.', '?', '?'], 'down' => [ '.', '|', '?', '?', "'", '?', '?'], 'left' => [ '-', '-', '?', '?', '-', '?', '?'], 'right' => [ '-', '-', '?', '?', '-', '?', '?'], 'upleft' => [ "'", '\\', '.', '-', '-', '|', "'"], 'leftup' => [ '-', '\\', "'", '-', '.', '|', "'"], 'downleft' => [ '.', '/', "'", '-', '-', '|', "'"], 'leftdown' => [ '-', '/', '.', '-', "'", '|', "'"], 'upright' => [ "'", '/', '.', '-', '-', '|', "'"], 'rightup' => [ '-', '/', "'", '-', '.', '|', "'"], 'downright' => [ '.', '\\', "'", '-', '-', '|', "'"], 'rightdown' => [ '-', '\\', '.', '-', "'", '|', "'"], } ; sub new { my ($class, $element_definition) = @_ ; my $self = bless {}, __PACKAGE__ ; $self->setup ( $element_definition->{GLYPHS} || $DEFAULT_GLYPHS, $element_definition->{END_X}, $element_definition->{END_Y}, $element_definition->{DIRECTION}, $element_definition->{EDITABLE}, ) ; return $self ; } #----------------------------------------------------------------------------- sub setup { my ($self, $glyphs, $end_x, $end_y, $direction, $editable) = @_ ; (my ($stripes, $width, $height), $direction) = get_arrow($glyphs, $end_x, $end_y, $direction) ; $self->set ( GLYPHS => $glyphs, STRIPES => $stripes, WIDTH => $width, HEIGHT => $height, DIRECTION => $direction, END_X => $end_x, END_Y => $end_y, ) ; } #----------------------------------------------------------------------------- my %direction_to_arrow = ( 'origin' => \&draw_origin, 'up' => \&draw_up, 'down' => \&draw_down, 'left' => \&draw_left, 'up-left' => \&draw_upleft, 'left-up' => \&draw_leftup, 'down-left' => \&draw_downleft, 'left-down' => \&draw_leftdown, 'right' => \&draw_right, 'up-right' => \&draw_upright, 'right-up' => \&draw_rightup, 'down-right' => \&draw_downright, 'right-down' => \&draw_rightdown, ) ; sub get_arrow { my ($glyphs, $end_x, $end_y, $direction) = @_ ; use constant CENTER => 1 ; use constant LEFT => 0 ; use constant RIGHT => 2 ; use constant UP => 0 ; use constant DOWN => 2 ; my @position_to_direction = ( [$direction =~ /^up/ ? 'up-left' : 'left-up', 'left', $direction =~ /^down/ ? 'down-left' : 'left-down'] , ['up', 'origin', 'down'], [$direction =~ /^up/ ? 'up-right' : 'right-up', 'right', $direction =~ /^down/ ? 'down-right' : 'right-down'], ) ; $direction = $position_to_direction [$end_x == 0 ? CENTER : $end_x < 0 ? LEFT : RIGHT] [$end_y == 0 ? CENTER : $end_y < 0 ? UP : DOWN] ; my $drawing_sub = $direction_to_arrow{$direction} ; return($drawing_sub->($glyphs, $end_x, $end_y), $direction) ; } #-------------------------------------------------------------------------------------------------------------- sub draw_origin { my ($glyphs, $end_x, $end_y) = @_ ; my ($start, $body, $connection, $body_2, $end, $vertical, $diagonal_connection) = @{$glyphs->{origin}} ; my ($stripes, $width, $height) = ([], 1, 1) ; push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; return($stripes, $width, $height) ; } #-------------------------------------------------------------------------------------------------------------- sub draw_up { my ($glyphs, $end_x, $end_y) = @_ ; my ($start, $body, $connection, $body_2, $end, $vertical, $diagonal_connection) = @{$glyphs->{up}} ; my ($width, $height) = ( $end_x + 1, -$end_y + 1) ; my @stripes ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; for(1 .. $height - 1) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => -$_, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => $end_y, }; return(\@stripes, $width, $height) ; } #-------------------------------------------------------------------------------------------------------------- sub draw_down { my ($glyphs, $end_x, $end_y) = @_ ; my ($start, $body, $connection, $body_2, $end, $vertical, $diagonal_connection) = @{$glyphs->{down}} ; my ($width, $height) = ( $end_x + 1, $end_y + 1) ; my @stripes ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; for(1 .. $height - 1) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => $_, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => $end_y, }; return(\@stripes, $width, $height) ; } #-------------------------------------------------------------------------------------------------------------- sub draw_left { my ($glyphs, $end_x, $end_y) = @_ ; my ($start, $body, $connection, $body_2, $end, $vertical, $diagonal_connection) = @{$glyphs->{left}} ; my ($width, $height) = ( -$end_x + 1, $end_y + 1) ; my @stripes ; my $stripe = $end . ($body x ( -$end_x - 1)) . $start ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $stripe, 'WIDTH' => length($stripe), 'X_OFFSET' => $end_x, 'Y_OFFSET' => 0, }; return(\@stripes, $width, $height) ; } #-------------------------------------------------------------------------------------------------------------- sub draw_right { my ($glyphs, $end_x, $end_y) = @_ ; my ($start, $body, $connection, $body_2, $end, $vertical, $diagonal_connection) = @{$glyphs->{right}} ; my ($width, $height) = ($end_x + 1, $end_y + 1) ; my @stripes ; my $stripe = $start . ($body x ($end_x - 1)) . $end ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $stripe, 'WIDTH' => length($stripe), 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; return(\@stripes, $width, $height) ; } #-------------------------------------------------------------------------------------------------------------- sub draw_upright { my ($glyphs, $end_x, $end_y) = @_ ; my ($start, $body, $connection, $body_2, $end, $vertical, $diagonal_connection) = @{$glyphs->{upright}} ; my ($width, $height) = ( $end_x + 1, -$end_y + 1) ; my ($position_x, $position_y) = (0, 0) ; my @stripes ; #~ require Enbugger ; #~ Enbugger->stop ; if($end_x >= -$end_y) # enought horizontal length to have a proper diagonal up { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => $position_x++, # diagonal 'Y_OFFSET' => $position_y--, # diagonal }; for(-$position_y .. (-$end_y - 1)) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => $position_x++, # diagonal 'Y_OFFSET' => $position_y--, # diagonal }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $connection, 'WIDTH' => 1, 'X_OFFSET' => $position_x++, # going right 'Y_OFFSET' => $position_y, # staying horizontal }; if($end_x > -$end_y) { for($position_x .. ($end_x - 1)) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body_2, 'WIDTH' => 1, 'X_OFFSET' => $position_x++, # going right 'Y_OFFSET' => $position_y, # staying horizontal }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => $position_x, # finished 'Y_OFFSET' => $position_y, # finished }; } } if($end_x < -$end_y) # not enought horizontal length to have a proper diagonal up { my $number_of_verticals = ($height - $width) - 1 ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y--, # up }; for(1 .. $number_of_verticals) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $vertical, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y--, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $diagonal_connection, 'WIDTH' => 1, 'X_OFFSET' => $position_x++, # going right 'Y_OFFSET' => $position_y--, # going up } if($end_x != 0) ; my $number_of_diagonals = $height - ($number_of_verticals + 3) ; for(1 .. $number_of_diagonals) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => $position_x++, # going right 'Y_OFFSET' => $position_y--, # going up }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $connection, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y, }; } return(\@stripes, $width, $height) ; } #-------------------------------------------------------------------------------------------------------------- sub draw_upleft { my ($glyphs, $end_x, $end_y) = @_ ; my ($start, $body, $connection, $body_2, $end, $vertical, $diagonal_connection) = @{$glyphs->{upleft}} ; my ($width, $height) = ( -$end_x + 1, -$end_y + 1) ; my ($position_x, $position_y) = (0, 0) ; my @stripes ; #~ require Enbugger ; #~ Enbugger->stop ; if($width >= $height) # enought horizontal length to have a proper diagonal up { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => $position_x--, 'Y_OFFSET' => $position_y--, }; for(-$position_y .. (-$end_y - 1)) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => $position_x--, 'Y_OFFSET' => $position_y--, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $connection, 'WIDTH' => 1, 'X_OFFSET' => $position_x--, 'Y_OFFSET' => $position_y, }; if($width > $height) { for(1 .. ($width - $height) - 1) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body_2, 'WIDTH' => 1, 'X_OFFSET' => $position_x--, 'Y_OFFSET' => $position_y, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y, }; } } else { my $number_of_verticals = ($height - $width) - 1 ; my $number_of_diagonals = $height - ($number_of_verticals + 3) ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y--, } ; for(1 .. $number_of_verticals) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $vertical, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y--, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $diagonal_connection, 'WIDTH' => 1, 'X_OFFSET' => $position_x--, 'Y_OFFSET' => $position_y--, } if($end_x != 0) ; for(1 .. $number_of_diagonals) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => $position_x--, 'Y_OFFSET' => $position_y--, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $connection, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y, }; } return(\@stripes, $width, $height) ; } #-------------------------------------------------------------------------------------------------------------- sub draw_leftup { my ($glyphs, $end_x, $end_y) = @_ ; my ($start, $body, $connection, $body_2, $end, $vertical, $diagonal_connection) = @{$glyphs->{leftup}} ; my ($width, $height) = ( -$end_x + 1, -$end_y + 1) ; my ($position_x, $position_y) = (0, 0) ; my @stripes ; #~ require Enbugger ; #~ Enbugger->stop ; #~ print "leftup\n" ; if($width > $height) # enought horizontal length to have a proper diagonal up { my $start_body_connector = $connection . $body_2 x (($width - $height) - 1) . $start ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $start_body_connector, 'WIDTH' => length($start_body_connector), 'X_OFFSET' => - length($start_body_connector) + 1, 'Y_OFFSET' => $position_y--, }; $position_x -= length($start_body_connector) ; for(1 .. ($height - 2)) # two connectors { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => $position_x--, 'Y_OFFSET' => $position_y--, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y, }; } else { my $number_of_verticals = $height - $width ; my $number_of_diagonals = $height - ($number_of_verticals + 2) ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $connection, 'WIDTH' => 1, 'X_OFFSET' => $position_x--, 'Y_OFFSET' => $position_y--, }; for(1 .. $number_of_diagonals) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => $position_x--, 'Y_OFFSET' => $position_y--, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $diagonal_connection, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y--, } if($end_x != $end_y) ; for(1 .. $number_of_verticals - 1) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $vertical, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y--, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y, } ; } return(\@stripes, $width, $height) ; } #--------------------------------------------------------------------------------- sub draw_rightup { my ($glyphs, $end_x, $end_y) = @_ ; my ($start, $body, $connection, $body_2, $end, $vertical, $diagonal_connection) = @{$glyphs->{rightup}} ; my ($width, $height) = ( $end_x + 1, -$end_y + 1) ; my ($position_x, $position_y) = (0, 0) ; my @stripes ; #~ require Enbugger ; #~ Enbugger->stop ; if($end_x > -$end_y) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => $position_x++, 'Y_OFFSET' => $position_y, }; for(1 .. ($width - $height) - 1) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body_2, 'WIDTH' => 1, 'X_OFFSET' => $position_x++, 'Y_OFFSET' => $position_y, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $connection, 'WIDTH' => 1, 'X_OFFSET' => $position_x++, 'Y_OFFSET' => $position_y--, }; for($position_x .. ($end_x - 1)) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => $position_x++, 'Y_OFFSET' => $position_y--, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => $end_x, 'Y_OFFSET' => $end_y, }; } else { my $number_of_verticals = ($height == $width) ? 0 : ($height - $width) -1 ; my $has_diagonal_connection = ($height == $width) ? 0 : 1 ; my $number_of_diagonals = $height - ($number_of_verticals + 2 + $has_diagonal_connection) ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $connection, 'WIDTH' => 1, 'X_OFFSET' => $position_x++, 'Y_OFFSET' => $position_y--, }; for(1 .. $number_of_diagonals) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => $position_x++, 'Y_OFFSET' => $position_y--, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $diagonal_connection, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y--, } if $has_diagonal_connection ; for(1 .. $number_of_verticals) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $vertical, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y--, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y--, } if($end_x != 0) ; } return(\@stripes, $width, $height) ; } #--------------------------------------------------------------------------------- sub draw_downleft { my ($glyphs, $end_x, $end_y) = @_ ; my ($start, $body, $connection, $body_2, $end, $vertical, $diagonal_connection) = @{$glyphs->{downleft}} ; my ($width, $height) = ( -$end_x + 1, $end_y + 1) ; my ($position_x, $position_y) = (0, 0) ; my @stripes ; #~ require Enbugger ; #~ Enbugger->stop ; if($width >= $height) # enought horizontal length to have a proper diagonal up { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => $position_x--, 'Y_OFFSET' => $position_y++, }; for(1 .. ($height - 2)) # two connectors { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => $position_x--, 'Y_OFFSET' => $position_y++, }; } my $left_text = $body_2 x (($width - $height) - 1) ; if($width > $height) { $left_text = $end . $body_2 x (($width - $height) - 1) ; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $left_text . $connection, 'WIDTH' => length($left_text) + 1, 'X_OFFSET' => $end_x, 'Y_OFFSET' => $position_y, }; } else # not enought horizontal length to have a proper diagonal up { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y++, }; for (1 .. ($height - $width) - 1) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $vertical, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y++, }; } if($end_x != 0) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $diagonal_connection, 'WIDTH' => 1, 'X_OFFSET' => $position_x--, 'Y_OFFSET' => $position_y++, } } for(1 .. (-$end_x + $position_x)) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => $position_x--, 'Y_OFFSET' => $position_y++, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $connection, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y, }; } return(\@stripes, $width, $height) ; } #---------------------------------------------------------------------------------------------------------- sub draw_leftdown { my ($glyphs, $end_x, $end_y) = @_ ; my ($start, $body, $connection, $body_2, $end, $vertical, $diagonal_connection) = @{$glyphs->{leftdown}} ; my ($width, $height) = ( -$end_x + 1, $end_y + 1) ; my ($position_x, $position_y) = (0, 0) ; my @stripes ; #~ require Enbugger ; #~ Enbugger->stop ; if($width >= $height) # enought horizontal length to have a proper diagonal up { my $start_body_connector = $connection . $body_2 x (($width - $height) - 1) ; if($width > $height) { $start_body_connector .= $start ; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $start_body_connector, 'WIDTH' => length($start_body_connector), 'X_OFFSET' => - length($start_body_connector) + 1, 'Y_OFFSET' => $position_y++, }; $position_x -= length($start_body_connector) ; for(1 .. ($height - 2)) # two connectors { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => $position_x--, 'Y_OFFSET' => $position_y++, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y, }; } else { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $connection, 'WIDTH' => 1, 'X_OFFSET' => $position_x--, 'Y_OFFSET' => $position_y++, }; for(1 .. (-$end_x + $position_x)) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => $position_x--, 'Y_OFFSET' => $position_y++, }; } if($end_x != 0) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $diagonal_connection, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y++, } } for (1 .. ($height - $width) - 1) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $vertical, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y++, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y, }; } return(\@stripes, $width, $height) ; } #---------------------------------------------------------------------------------------------------------- sub draw_downright { my ($glyphs, $end_x, $end_y) = @_ ; my ($start, $body, $connection, $body_2, $end, $vertical, $diagonal_connection) = @{$glyphs->{downright}} ; my ($width, $height) = ( $end_x + 1, $end_y + 1) ; my ($position_x, $position_y) = (0, 0) ; my @stripes ; #~ require Enbugger ; #~ Enbugger->stop ; if($end_x >= $end_y) # enought horizontal length to have a proper diagonal up { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => $position_x++, # diagonal 'Y_OFFSET' => $position_y++, # diagonal }; for($position_y .. ($end_y - 1)) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => $position_x++, # diagonal 'Y_OFFSET' => $position_y++, # diagonal }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $connection, 'WIDTH' => 1, 'X_OFFSET' => $position_x++, # going right 'Y_OFFSET' => $position_y, # staying horizontal }; if($end_x > $end_y) { for($position_x .. ($end_x - 1)) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body_2, 'WIDTH' => 1, 'X_OFFSET' => $position_x++, # going right 'Y_OFFSET' => $position_y, # staying horizontal }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => $position_x, # finished 'Y_OFFSET' => $position_y, # finished }; } } if($end_x < $end_y) # not enought horizontal length to have a proper diagonal up { my $number_of_verticals = ($end_y - $end_x) - 1 ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y++, } ; for(1 .. $number_of_verticals) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $vertical, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y++, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $diagonal_connection, 'WIDTH' => 1, 'X_OFFSET' => $position_x++, 'Y_OFFSET' => $position_y++, } if($end_x != 0) ; my $number_of_diagonals = $height - ($number_of_verticals + 3) ; for(1 .. $number_of_diagonals) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => $position_x++, 'Y_OFFSET' => $position_y++, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $connection, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y, }; } return(\@stripes, $width, $height) ; } sub draw_rightdown { my ($glyphs, $end_x, $end_y) = @_ ; my ($start, $body, $connection, $body_2, $end, $vertical, $diagonal_connection) = @{$glyphs->{rightdown}} ; my ($width, $height) = ( $end_x + 1, $end_y + 1) ; my ($position_x, $position_y) = (0, 0) ; my @stripes ; #~ require Enbugger ; #~ Enbugger->stop ; if($end_x >= $end_y) # enought horizontal length to have a proper diagonal down { if($end_x > $end_y) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => $position_x++, # going right 'Y_OFFSET' => $position_y, # stay on this line }; for(1 .. ($end_x - $end_y) - 1) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body_2, 'WIDTH' => 1, 'X_OFFSET' => $position_x++, 'Y_OFFSET' => $position_y, }; } } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $connection, 'WIDTH' => 1, 'X_OFFSET' => $position_x++, 'Y_OFFSET' => $position_y++, }; for(1 .. ($end_y - $position_y)) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => $position_x++, 'Y_OFFSET' => $position_y++, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y, }; } if($end_x < $end_y) # not enought horizontal length to have a proper diagonal up { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $connection, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y++, }; for(1 .. (($end_x - 1) - $position_x)) { $position_x++ ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y++, }; } if($end_x != 0) { $position_x++ ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $diagonal_connection, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y++, } } for (0 .. ($end_y -$position_y) - 1) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $vertical, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y++, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => $position_x, 'Y_OFFSET' => $position_y++, }; } return(\@stripes, $width, $height) ; } #----------------------------------------------------------------------------- sub get_selection_action { my ($self, $x, $y) = @_ ; if ( ($x == 0 && $y == 0) || ($x == $self->{END_X} && $y == $self->{END_Y}) ) { 'resize' ; } else { 'move' ; } } #----------------------------------------------------------------------------- sub get_connector_points { my ($self) = @_ ; return ( {X => 0, Y => 0, NAME => 'start'}, {X => $self->{END_X}, Y => $self->{END_Y}, NAME => 'end'}, ) ; } #----------------------------------------------------------------------------- sub get_named_connection { my ($self, $name) = @_ ; if($name eq 'start') { return( {X => 0, Y => 0, NAME => 'start'} ) ; } elsif($name eq 'end') { return( {X => $self->{END_X}, Y => $self->{END_Y}, NAME => 'end'} ) ; } else { return ; } } #----------------------------------------------------------------------------- sub get_direction { my ($self) = @_ ; return $self->{DIRECTION} ; } sub change_direction { my ($self, $x, $y) = @_ ; my $direction = $self->get_direction() ; if($direction =~ /(.*)-(.*)/) { $self->resize(0, 0, 0, 0, "$2-$1") ; } } #----------------------------------------------------------------------------- sub move_connector { my ($self, $connector_name, $x_offset, $y_offset, $hint) = @_ ; if($connector_name eq 'start') { my ($x_offset, $y_offset, $width, $height, undef) = $self->resize(0, 0, $x_offset, $y_offset, $hint) ; return $x_offset, $y_offset, $width, $height, {X => $self->{END_X}, Y => $self->{END_Y}, NAME => 'start'} ; } elsif($connector_name eq 'end') { my ($x_offset, $y_offset, $width, $height, undef) = $self->resize(-1, -1, $self->{END_X} + $x_offset, $self->{END_Y} + $y_offset, $hint) ; return $x_offset, $y_offset, $width, $height, {X => $self->{END_X}, Y => $self->{END_Y}, NAME => 'end'} ; } else { die "unknown connector '$connector_name'!\n" ; } } #----------------------------------------------------------------------------- sub resize { my ($self, $reference_x, $reference_y, $new_x, $new_y, $hint, $connector_name) = @_ ; my $is_start ; if(defined $connector_name) { if($connector_name eq 'start') { $is_start++ ; } } else { if($reference_x == 0 && $reference_y == 0) { $is_start++ ; } } if($is_start) { my $x_offset = $new_x ; my $y_offset = $new_y ; my $new_end_x = $self->{END_X} - $x_offset ; my $new_end_y = $self->{END_Y} - $y_offset ; $self->setup($self->{GLYPHS}, $new_end_x, $new_end_y, $hint || $self->{DIRECTION}, $self->{EDITABLE}) ; return($x_offset, $y_offset, $self->{WIDTH}, $self->{HEIGHT}, 'start') ; } else { my $new_end_x = $new_x ; my $new_end_y = $new_y ; $self->setup($self->{GLYPHS}, $new_end_x, $new_end_y, $hint || $self->{DIRECTION}, $self->{EDITABLE}) ; return(0, 0, $self->{WIDTH}, $self->{HEIGHT}, 'end') ; } } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.51.3/lib/App/Asciio/stripes/editable_box2.pm000444001750000144 2754612544473514 22571 0ustar00nadimusers000000000000 package App::Asciio::stripes::editable_box2 ; use base App::Asciio::stripes::single_stripe ; use strict; use warnings; use List::Util qw(min max) ; use Readonly ; use Clone ; #----------------------------------------------------------------------------- Readonly my $DEFAULT_BOX_TYPE => [ [1, 'top', '.', '-', '.', 1, ], [0, 'title separator', '|', '-', '|', 1, ], [1, 'body separator', '| ', '|', ' |', 1, ], [1, 'bottom', '\'', '-', '\'', 1, ], ] ; sub new { my ($class, $element_definition) = @_ ; my $self = bless {}, __PACKAGE__ ; $self->setup ( $element_definition->{TEXT_ONLY}, $element_definition->{TITLE}, $element_definition->{BOX_TYPE} || Clone::clone($DEFAULT_BOX_TYPE), 1, 1, $element_definition->{RESIZABLE}, $element_definition->{EDITABLE}, $element_definition->{AUTO_SHRINK}, ) ; return $self ; } #----------------------------------------------------------------------------- sub setup { my ($self, $text_only, $title_text, $box_type, $end_x, $end_y, $resizable, $editable, $auto_shrink) = @_ ; my ($text_width, @lines) = (0) ; for my $line (split("\n", $text_only)) { $text_width = max($text_width, length($line)) ; push @lines, $line ; } my ($title_width, @title_lines) = (0) ; $title_text = '' unless defined $title_text ; for my $title_line (split("\n", $title_text)) { $title_width = max($title_width, length($title_line)) ; push @title_lines, $title_line ; } my ($extra_width, $extra_height) = get_box_frame_size_overhead($box_type) ; my $display_title = (defined $title_text and $title_text ne '') ? 1 : 0 ; $text_width = max($text_width, $title_width) if $display_title; if($auto_shrink) { ($end_x, $end_y) = (-5, -5) ; } $end_x = max($end_x, $text_width + $extra_width, $title_width + $extra_width) ; $end_y = max($end_y, scalar(@lines) + $extra_height + scalar(@title_lines)) ; my ($box_top, $box_left, $box_right, $box_bottom, $title_separator, $title_left, $title_right) = get_box_frame_elements($box_type, $end_x) ; my $text = $box_top ; for my $title_line (@title_lines) { my $pading = ($end_x - (length($title_left . $title_line . $title_right))) ; my $left_pading = int($pading / 2) ; my $right_pading = $pading - $left_pading ; $text .= $title_left . (' ' x $left_pading) . $title_line . (' ' x $right_pading) . $title_right ."\n" ; } $text .= $title_separator ; for my $line (@lines) { $text .= $box_left . $line . (' ' x ($end_x - (length($line) + $extra_width))) . $box_right . "\n" ; } for (1 .. ($end_y - (@lines + $extra_height + @title_lines))) { $text .= $box_left . (' ' x ($end_x - $extra_width)) . $box_right . "\n" ; } $text .= $box_bottom ; $self->set ( TEXT => $text, TITLE => $title_text, WIDTH => $end_x, HEIGHT => $end_y, TEXT_ONLY => $text_only, BOX_TYPE => $box_type, RESIZABLE => $resizable, EDITABLE => $editable, AUTO_SHRINK => $auto_shrink, ) ; } #----------------------------------------------------------------------------- use Readonly ; Readonly my $TOP => 0 ; Readonly my $TITLE_SEPARATOR => 1 ; Readonly my $BODY_SEPARATOR => 2 ; Readonly my $BOTTOM => 3; Readonly my $DISPLAY => 0 ; Readonly my $NAME => 1 ; Readonly my $LEFT => 2 ; Readonly my $BODY => 3 ; Readonly my $RIGHT => 4 ; sub get_box_frame_size_overhead { my ($box_type) = @_ ; my @displayed_elements = grep { $_->[$DISPLAY] } @{$box_type} ; my $extra_width = max(0, map {length} map {$_->[$LEFT]}@displayed_elements) + max(0, map {length} map {$_->[$RIGHT]}@displayed_elements) ; my $extra_height = 0 ; for ($TOP, $TITLE_SEPARATOR, $BOTTOM) { $extra_height++ if defined $box_type->[$_][$DISPLAY] && $box_type->[$_][$DISPLAY] ; } return($extra_width, $extra_height) ; } sub get_box_frame_elements { my ($box_type, $width) = @_ ; my ($box_top, $box_left, $box_right, $box_bottom, $title_separator, $title_left, $title_right) = map {''} (1 .. 7) ; if($box_type->[$TOP][$DISPLAY]) { my $box_left_and_right_length = length($box_type->[$TOP][$LEFT]) + length($box_type->[$TOP][$RIGHT]) ; $box_top = $box_type->[$TOP][$LEFT] . ($box_type->[$TOP][$BODY] x ($width - $box_left_and_right_length)) . $box_type->[$TOP][$RIGHT] . "\n" ; } $title_left = $box_type->[$TITLE_SEPARATOR][$LEFT] if($box_type->[$BODY_SEPARATOR][$DISPLAY]) ; $title_right = $box_type->[$TITLE_SEPARATOR][$RIGHT] if($box_type->[$BODY_SEPARATOR][$DISPLAY]) ; if($box_type->[$TITLE_SEPARATOR][$DISPLAY]) { my $title_left_and_right_length = length($title_left) + length($title_right) ; my $title_separator_body = $box_type->[$TITLE_SEPARATOR][$BODY] ; $title_separator_body = ' ' unless defined $title_separator_body ; $title_separator_body = ' ' if $title_separator_body eq '' ; $title_separator = $title_left . ($title_separator_body x ($width - $title_left_and_right_length)) . $title_right . "\n" ; } $box_left = $box_type->[$BODY_SEPARATOR][$LEFT] if($box_type->[$BODY_SEPARATOR][$DISPLAY]) ; $box_right = $box_type->[$BODY_SEPARATOR][$RIGHT] if($box_type->[$BODY_SEPARATOR][$DISPLAY]) ; if($box_type->[$BOTTOM][$DISPLAY]) { my $box_left_and_right_length = length($box_type->[$BOTTOM][$LEFT]) + length($box_type->[$BOTTOM][$RIGHT]) ; $box_bottom = $box_type->[$BOTTOM][$LEFT] . ($box_type->[$BOTTOM][$BODY] x ($width - $box_left_and_right_length)) . $box_type->[$BOTTOM][$RIGHT] ; } return ($box_top, $box_left, $box_right, $box_bottom, $title_separator, $title_left, $title_right) ; } #----------------------------------------------------------------------------- sub get_selection_action { my ($self, $x, $y) = @_ ; if ( ($x == $self->{WIDTH} - 1 && $y == $self->{HEIGHT} - 1) ) { 'resize' ; } else { 'move' ; } } #----------------------------------------------------------------------------- sub match_connector { my ($self, $x, $y) = @_ ; my $middle_width = int($self->{WIDTH} / 2) ; my $middle_height = int($self->{HEIGHT} / 2) ; if($x == $middle_width && $y == -1) { return {X => $x, Y => $y, NAME => 'top_center'} ; } elsif($x == $middle_width && $y == $self->{HEIGHT}) { return {X => $x, Y => $y, NAME => 'bottom_center'} ; } if($x == -1 && $y == $middle_height) { return {X => $x, Y => $y, NAME => 'left_center'} ; } elsif($x == $self->{WIDTH} && $y == $middle_height) { return {X => $x, Y => $y, NAME => 'right_center'} ; } elsif($x >= 0 && $x < $self->{WIDTH} && $y >= 0 && $y < $self->{HEIGHT}) { return {X => $middle_width, Y => -1, NAME => 'to_be_optimized'} ; } elsif($self->{ALLOW_BORDER_CONNECTION} && $x >= -1 && $x <= $self->{WIDTH} && $y >= -1 && $y <= $self->{HEIGHT}) { return {X => $x, Y => $y, NAME => 'border'} ; } else { return ; } } #----------------------------------------------------------------------------- sub get_connection_points { my ($self) = @_ ; my $middle_width = int($self->{WIDTH} / 2) ; my $middle_height = int($self->{HEIGHT} / 2) ; return ( {X => $middle_width, Y => -1, NAME => 'top_center'}, {X => $middle_width, Y => $self->{HEIGHT}, NAME => 'bottom_center'}, {X => -1, Y => $middle_height, NAME => 'left_center'}, {X => $self->{WIDTH}, Y => $middle_height, NAME => 'right_center'}, ) ; } #----------------------------------------------------------------------------- sub get_extra_points { my ($self) = @_ ; if($self->{RESIZABLE} && ! $self->is_auto_shrink()) { return {X => $self->{WIDTH} - 1, Y => $self->{HEIGHT} - 1, NAME => 'resize'} ; } else { return ; } } #----------------------------------------------------------------------------- sub get_named_connection { my ($self, $name) = @_ ; my $middle_width = int($self->{WIDTH} / 2) ; my $middle_height = int($self->{HEIGHT} / 2) ; if($name eq 'top_center') { return( {X => $middle_width, Y => -1, NAME => 'top_center'} ) ; } elsif($name eq 'bottom_center') { return( {X => $middle_width, Y => $self->{HEIGHT}, NAME => 'bottom_center'} ) ; } elsif($name eq 'left_center') { return {X => -1, Y => $middle_height, NAME => 'left_center'}, } elsif($name eq 'right_center') { return {X => $self->{WIDTH}, Y => $middle_height, NAME => 'right_center'}, } else { return ; } } #----------------------------------------------------------------------------- sub allow_border_connection { my($self, $allow) = @_ ; $self->{ALLOW_BORDER_CONNECTION} = $allow ; } #----------------------------------------------------------------------------- sub is_border_connection_allowed { my($self) = @_ ; return $self->{ALLOW_BORDER_CONNECTION} ; } #----------------------------------------------------------------------------- sub flip_auto_shrink { my($self) = @_ ; $self->{AUTO_SHRINK} ^= 1 ; } #----------------------------------------------------------------------------- sub is_auto_shrink { my($self) = @_ ; return $self->{AUTO_SHRINK} ; } #----------------------------------------------------------------------------- sub resize { my ($self, $reference_x, $reference_y, $new_x, $new_y) = @_ ; return(0, 0, $self->{WIDTH}, $self->{HEIGHT}) unless $self->{RESIZABLE} ; my $new_end_x = $new_x ; my $new_end_y = $new_y ; if($new_end_x >= 0 && $new_end_y >= 0) { $self->setup ( $self->{TEXT_ONLY}, $self->{TITLE}, $self->{BOX_TYPE}, $new_end_x + 1, $new_end_y + 1, $self->{RESIZABLE}, $self->{EDITABLE}, $self->{AUTO_SHRINK}, ) ; } return(0, 0, $self->{WIDTH}, $self->{HEIGHT}) ; } #----------------------------------------------------------------------------- sub get_text { my ($self) = @_ ; return($self->{TITLE}, $self->{TEXT_ONLY}) ; } #----------------------------------------------------------------------------- sub set_text { my ($self, $title, $text) = @_ ; my @displayed_elements = grep { $_->[$DISPLAY] } @{$self->{BOX_TYPE}} ; $text = 'edit_me' if($text eq '' && @displayed_elements == 0) ; $self->setup ( $text, $title, $self->{BOX_TYPE}, $self->{WIDTH}, $self->{HEIGHT}, $self->{RESIZABLE}, $self->{EDITABLE}, $self->{AUTO_SHRINK}, ) ; } #----------------------------------------------------------------------------- sub get_box_type { my ($self) = @_ ; return($self->{BOX_TYPE}) ; } #----------------------------------------------------------------------------- sub set_box_type { my ($self, $box_type) = @_ ; $self->setup ( $self->{TEXT_ONLY}, $self->{TITLE}, $box_type, $self->{WIDTH}, $self->{HEIGHT}, $self->{RESIZABLE}, $self->{EDITABLE}, $self->{AUTO_SHRINK}, ) ; } #----------------------------------------------------------------------------- sub edit { my ($self, $asciio) = @_ ; return unless $self->{EDITABLE} ; my $text = $self->{TEXT_ONLY} ; $text = make_vertical_text($text) if $self->{VERTICAL_TEXT} ; ($text, my $title) = $self->display_box_edit_dialog($self->{TITLE}, $text) ; my $tab_as_space = $self->{TAB_AS_SPACES} || (' ' x 3) ; $text =~ s/\t/$tab_as_space/g ; $title=~ s/\t/$tab_as_space/g ; $text = make_vertical_text($text) if $self->{VERTICAL_TEXT} ; $self->set_text($title, $text) ; } #----------------------------------------------------------------------------- sub rotate_text { my ($self) = @_ ; my $text = make_vertical_text($self->{TEXT_ONLY}) ; $self->set_text($self->{TITLE}, $text) ; $self->shrink() ; $self->{VERTICAL_TEXT} ^= 1 ; } #----------------------------------------------------------------------------- sub shrink { my ($self) = @_ ; $self->setup ( $self->{TEXT_ONLY}, $self->{TITLE}, $self->{BOX_TYPE}, -5, -5, $self->{RESIZABLE}, $self->{EDITABLE}, $self->{AUTO_SHRINK}, ) ; } #----------------------------------------------------------------------------- sub make_vertical_text { my ($text) = @_ ; my @lines = map{[split '', $_]} split "\n", $text ; my $vertical = '' ; my $found_character = 1 ; my $index = 0 ; while($found_character) { my $line ; $found_character = 0 ; for(@lines) { if(defined $_->[$index]) { $line.= $_->[$index] ; $found_character++ ; } else { $line .= ' ' ; } } $line =~ s/\s+$//; $vertical .= "$line\n" if $found_character ; $index++ ; } return $vertical ; } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.51.3/lib/App/Asciio/stripes/process_box.pm000444001750000144 1761712544473514 22412 0ustar00nadimusers000000000000 package App::Asciio::stripes::process_box ; use base App::Asciio::stripes::stripes ; use strict; use warnings; use List::Util qw(min max) ; use Readonly ; #----------------------------------------------------------------------------- sub new { my ($class, $element_definition) = @_ ; my $self = bless {}, __PACKAGE__ ; $self->setup ( $element_definition->{TEXT_ONLY}, $element_definition->{WIDTH} || 1, $element_definition->{HEIGHT} || 1, $element_definition->{EDITABLE}, $element_definition->{RESIZABLE}, ) ; return $self ; } #----------------------------------------------------------------------------- sub setup { my ($self, $text_only, $end_x, $end_y, $editable, $resizable) = @_ ; Readonly my $side_glyphs_size => 4 ; $text_only = '' unless defined $text_only ; my @lines = split("\n", $text_only) ; @lines = ('') unless @lines; my $number_of_lines = scalar(@lines) ; if($end_y - 3 > $number_of_lines) { my $lines_to_add = ($end_y - 3) - $number_of_lines ; $lines_to_add += $lines_to_add % 2 ; # number of lines is always even unshift @lines, map {''} (1 .. $lines_to_add / 2) ; push @lines, map {''} (1 .. $lines_to_add / 2) ; $number_of_lines += $lines_to_add ; } my $half_the_lines = int($number_of_lines / 2) ; my $element_width = 0 ; my $current_half_the_lines = $half_the_lines ; my (@lines_width_plus_offset) ; for my $line (@lines) { push @lines_width_plus_offset, length($line) + abs($current_half_the_lines) ; $current_half_the_lines-- ; } my $text_width_plus_offset = max(@lines_width_plus_offset, $end_x) ; my @top_lines = (splice @lines, 0, $number_of_lines / 2) ; my $center_line = shift @lines || '' ; my @bottom_lines = @lines ; push @bottom_lines, '' for (1 .. scalar(@top_lines) - scalar(@bottom_lines)) ; my (@stripes, $strip_text, $x_offset, $y_offset) ; $strip_text = '_' x (($text_width_plus_offset - 1) + $side_glyphs_size) . "\n\\" . ' ' x (($text_width_plus_offset - 2) + $side_glyphs_size) . "\\" ; push @stripes, { 'HEIGHT' => 2, 'TEXT' => $strip_text, 'WIDTH' => $text_width_plus_offset + $side_glyphs_size, 'X_OFFSET' => 0, 'Y_OFFSET' =>0, } ; $x_offset = 1 ; $y_offset = 2 ; $current_half_the_lines = $half_the_lines ; for my $line (@top_lines) { my $front_padding = ' ' x $current_half_the_lines ; my $padding = ' ' x ($text_width_plus_offset - (length($line) + $current_half_the_lines)) ; my $strip_text = "\\ $front_padding$line$padding \\" ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $strip_text, 'WIDTH' => length($strip_text), 'X_OFFSET' => $x_offset, 'Y_OFFSET' => $y_offset , } ; $x_offset++ ; $y_offset++ ; $current_half_the_lines-- ; } my $padding = ' ' x ($text_width_plus_offset - length($center_line)) ; $strip_text = ') ' . $center_line . $padding . ' )' ; $element_width = length($strip_text) + $y_offset - 1 ; # first stripe is two lines high, compensate offset by substracting one my $left_center_x = $y_offset - 2 ; # compensate as above and shft left push @stripes, { 'HEIGHT' => 1, 'TEXT' => $strip_text, 'WIDTH' => length($strip_text), 'X_OFFSET' => $x_offset, 'Y_OFFSET' => $y_offset, }; $y_offset++ ; $x_offset-- ; $current_half_the_lines = 1; for my $line (@bottom_lines) { my $front_padding = ' ' x $current_half_the_lines ; my $padding = ' ' x ($text_width_plus_offset - (length($line) + $current_half_the_lines)) ; my $strip_text = "/ $front_padding$line$padding /" ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $strip_text, 'WIDTH' => length($strip_text), 'X_OFFSET' => $x_offset, 'Y_OFFSET' => $y_offset , } ; $x_offset-- ; $y_offset++ ; $current_half_the_lines++; } $strip_text = '/' . '_' x (($text_width_plus_offset - 2) + $side_glyphs_size ) . '/' ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $strip_text, 'WIDTH' => $text_width_plus_offset + $side_glyphs_size, 'X_OFFSET' => 0, 'Y_OFFSET' => $y_offset, }; $self->set ( STRIPES => \@stripes, WIDTH => $element_width, HEIGHT => $y_offset + 1, LEFT_CENTER_X => $left_center_x, RESIZE_POINT_X => $text_width_plus_offset + $side_glyphs_size - 1, TEXT_ONLY => $text_only, EDITABLE => $editable, RESIZABLE => $resizable, ) ; } #----------------------------------------------------------------------------- sub get_selection_action { my ($self, $x, $y) = @_ ; if ( ($x == $self->{RESIZE_POINT_X} && $y == $self->{HEIGHT} - 1) ) { 'resize' ; } else { 'move' ; } } #----------------------------------------------------------------------------- sub match_connector { my ($self, $x, $y) = @_ ; my $middle_width = int($self->{WIDTH} / 2) ; my $middle_height = int($self->{HEIGHT} / 2) ; if($x == $middle_width && $y == -1) { return {X => $x, Y => $y, NAME => 'top_center'} ; } elsif($x == $middle_width && $y == $self->{HEIGHT}) { return {X => $x, Y => $y, NAME => 'bottom_center'} ; } if($x == $self->{LEFT_CENTER_X} && $y == $middle_height) { return {X => $x, Y => $y, NAME => 'left_center'} ; } elsif($x == $self->{WIDTH} && $y == $middle_height) { return {X => $x, Y => $y, NAME => 'right_center'} ; } elsif($x >= 0 && $x < $self->{WIDTH} && $y >= 0 && $y < $self->{HEIGHT}) { return {X => $middle_width, Y => -1, NAME => 'to_be_optimized'} ; } else { return ; } } #----------------------------------------------------------------------------- sub get_connection_points { my ($self) = @_ ; my $middle_width = int($self->{WIDTH} / 2) ; my $middle_height = int($self->{HEIGHT} / 2) ; return ( {X => $middle_width, Y => -1, NAME => 'top_center'}, {X => $middle_width, Y => $self->{HEIGHT}, NAME => 'bottom_center'}, {X => $self->{LEFT_CENTER_X}, Y => $middle_height, NAME => 'left_center'}, {X => $self->{WIDTH}, Y => $middle_height, NAME => 'right_center'}, ) ; } #----------------------------------------------------------------------------- sub get_extra_points { my ($self) = @_ ; return ( {X => $self->{RESIZE_POINT_X}, Y => $self->{HEIGHT} - 1 , NAME => 'resize'}, ) ; } #----------------------------------------------------------------------------- sub get_named_connection { my ($self, $name) = @_ ; my $middle_width = int($self->{WIDTH} / 2) ; my $middle_height = int($self->{HEIGHT} / 2) ; if($name eq 'top_center') { return {X => $middle_width, Y => -1, NAME => 'top_center'} ; } elsif($name eq 'bottom_center') { return {X => $middle_width, Y => $self->{HEIGHT}, NAME => 'bottom_center'} ; } elsif($name eq 'left_center') { return {X => $self->{LEFT_CENTER_X}, Y => $middle_height, NAME => 'left_center'}, } elsif($name eq 'right_center') { return {X => $self->{WIDTH}, Y => $middle_height, NAME => 'right_center'}, } else { return ; } } #----------------------------------------------------------------------------- sub resize { my ($self, $reference_x, $reference_y, $new_x, $new_y) = @_ ; my $new_end_x = $new_x ; my $new_end_y = $new_y ; if($new_end_x >= 0 && $new_end_y >= 0) { $self->setup ( $self->{TEXT_ONLY}, $new_end_x + 1 - ($self->{WIDTH} - $self->{RESIZE_POINT_X}), # compensate for resize point X not equal to width $new_end_y + 1, $self->{EDITABLE}, $self->{RESIZABLE} ) ; } return(0, 0, $self->{WIDTH}, $self->{HEIGHT}) ; } #----------------------------------------------------------------------------- sub get_text { my ($self) = @_ ; return($self->{TEXT_ONLY}) ; } #----------------------------------------------------------------------------- sub set_text { my ($self, $text) = @_ ; $self->setup ( $text, $self->{RESIZE_POINT_X} - 3, # magic number are ugly $self->{HEIGHT} - 1, $self->{EDITABLE}, $self->{RESIZABLE} ) ; } #----------------------------------------------------------------------------- sub edit { my ($self, $asciio) = @_ ; return unless $self->{EDITABLE} ; my ($text_only) = $asciio->display_edit_dialog('asciio', $self->{TEXT_ONLY}) ; my $tab_as_space = $self->{TAB_AS_SPACES} || (' ' x 3) ; $text_only =~ s/\t/$tab_as_space/g ; $self->set_text($text_only) ; } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.51.3/lib/App/Asciio/stripes/editable_arrow2.pm000444001750000144 1765312544473514 23131 0ustar00nadimusers000000000000 package App::Asciio::stripes::editable_arrow2 ; use base App::Asciio::stripes::stripes ; use strict; use warnings; use List::Util qw(min max) ; use Readonly ; use Clone ; #----------------------------------------------------------------------------- Readonly my $DEFAULT_ARROW_TYPE => [ ['Up', '|', '|', '^', 1, ], ['45', '/', '/', '^', 1, ], ['Right', '-', '-', '>', 1, ], ['135', '\\', '\\', 'v', 1, ], ['Down', '|', '|', 'v', 1, ], ['225', '/', '/', 'v', 1, ], ['Left', '-', '-', '<', 1, ], ['315', '\\', '\\', '^', 1, ], ] ; sub new { my ($class, $element_definition) = @_ ; my $self = bless {}, __PACKAGE__ ; $self->setup ( $element_definition->{ARROW_TYPE} || Clone::clone($DEFAULT_ARROW_TYPE), $element_definition->{END_X}, $element_definition->{END_Y}, $element_definition->{EDITABLE}, ) ; return $self ; } #----------------------------------------------------------------------------- sub setup { my ($self, $arrow_type, $end_x, $end_y, $editable) = @_ ; my ($stripes, $real_end_x, $real_end_y) = get_arrow($arrow_type, $end_x, $end_y) ; $self->set ( STRIPES => $stripes, END_X => $real_end_x, END_Y => $real_end_y, ARROW_TYPE => $arrow_type, ) ; } #----------------------------------------------------------------------------- sub get_arrow { my ($arrow_type, $end_x, $end_y) = @_ ; my ($stripes, $real_end_x, $real_end_y, $height, $width) = ([]) ; $end_y *= 2 ; # compensate for aspect ratio my $direction = $end_x >= 0 ? $end_y <= 0 ? -$end_y > $end_x ? -$end_y / 4 > $end_x ? 'up' :'45' : -$end_y > $end_x / 2 ? '45' : 'right' : $end_y < $end_x ? $end_y < $end_x / 2 ? 'right' :'135' : $end_y / 4 < $end_x ? '135' : 'down' : $end_y < 0 ? $end_y < $end_x ? $end_y / 4 < $end_x ? 'up' : '315' : $end_y < $end_x / 2 ? '315' : 'left' : $end_y > -$end_x ? $end_y / 4 > -$end_x ? 'down' : '225' : $end_y > -$end_x / 2 ? '225' : 'left' ; $end_y /= 2 ; # done compensating for aspect ratio my $arrow ; for ($direction) { $_ eq 'up' and do { my ($start, $body, $end) = @{$arrow_type->[0]}[1 .. 3] ; $height = -$end_y + 1 ; $real_end_y = $end_y ; $real_end_x = 0 ; $arrow = $height == 2 ? $end . "\n" . $start : $end . "\n" . ("$body\n" x ($height -2)) . $start ; push @{$stripes}, { 'HEIGHT' => $height, 'TEXT' => $arrow, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => $end_y, }; last ; } ; $_ eq '45' and do { my ($start, $body, $end) = @{$arrow_type->[1]}[1 .. 3] ; $height = -$end_y + 1 ; $real_end_y = $end_y ; $width = $height ; $real_end_x = - $real_end_y; push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; for(my $position = -$end_y - 1 ; $position > 0 ; $position--) { push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => $position, 'Y_OFFSET' => -$position, }; } push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => -$end_y , 'Y_OFFSET' => $end_y , }; last ; } ; $_ eq 'right' and do { my ($start, $body, $end) = @{$arrow_type->[2]}[1 .. 3] ; $width = $end_x + 1 ; $real_end_x = $end_x ; $real_end_y = 0 ; $arrow = $width == 1 ? $end : $width == 2 ? $start . $end : $start . ($body x ($width -2)) . $end ; push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $arrow, 'WIDTH' => $width, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; last ; } ; $_ eq '135' and do { my ($start, $body, $end) = @{$arrow_type->[3]}[1 .. 3] ; $height = $end_y + 1 ; $real_end_y = $end_y ; $width = $height ; $real_end_x = $real_end_y ; push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => 0 , 'Y_OFFSET' => 0 , }; for(my $position = 1 ; $position < $end_y ; $position++) { push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => $position, 'Y_OFFSET' => $position, }; } push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => $end_y , 'Y_OFFSET' => $end_y , }; last ; } ; $_ eq 'down' and do { my ($start, $body, $end) = @{$arrow_type->[4]}[1 .. 3] ; $height = $end_y + 1 ; $real_end_y = $end_y ; $real_end_x = 0 ; $arrow = $height == 2 ? $start . "\n" . $end : $start . "\n" . ("$body\n" x ($height -2)) . $end ; push @{$stripes}, { 'HEIGHT' => $height, 'TEXT' => $arrow, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; last ; } ; $_ eq '225' and do { my ($start, $body, $end) = @{$arrow_type->[5]}[1 .. 3] ; $height = $end_y + 1 ; $real_end_y = $end_y ; $width = $height ; $real_end_x = -$real_end_y ; push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; for(my $position = $end_y - 1 ; $position > 0 ; $position--) { push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => -$position, 'Y_OFFSET' => $position, }; } push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => -$end_y , 'Y_OFFSET' => $end_y , }; last ; } ; $_ eq 'left' and do { my ($start, $body, $end) = @{$arrow_type->[6]}[1 .. 3] ; $width = -$end_x + 1 ; $real_end_y = 0 ; $real_end_x = $end_x ; $arrow = $width == 2 ? $end . $start : $end . ($body x ($width -2)) . $start ; push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $arrow, 'WIDTH' => $width, 'X_OFFSET' => $end_x, 'Y_OFFSET' => 0, }; last ; } ; $_ eq '315' and do { my ($start, $body, $end) = @{$arrow_type->[7]}[1 .. 3] ; $height = -$end_y + 1 ; $real_end_y = $end_y ; $width = $height ; $real_end_x = $real_end_y ; push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; for(my $position = 1 ; $position < -$end_y ; $position++) { push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => '\\', 'WIDTH' => 1, 'X_OFFSET' => -$position, 'Y_OFFSET' => -$position, }; } push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => $end_y, 'Y_OFFSET' => $end_y, }; last ; } ; } return($stripes, $real_end_x, $real_end_y) ; } #----------------------------------------------------------------------------- sub get_extra_points { my ($self) = @_ ; return ( {X => $self->{END_X}, Y => $self->{END_Y}, NAME => 'resize'}, ) ; } #----------------------------------------------------------------------------- sub get_selection_action { my ($self, $x, $y) = @_ ; if ($x == $self->{END_X} && $y == $self->{END_Y}) { 'resize' ; } else { 'move' ; } } #----------------------------------------------------------------------------- sub resize { my ($self, $reference_x, $reference_y, $new_x, $new_y) = @_ ; my $new_end_x = $new_x ; my $new_end_y = $new_y ; $self->setup($self->{ARROW_TYPE}, $new_end_x, $new_end_y, $self->{EDITABLE}) ; return(0, 0, $self->{END_X} + 1, $self->{END_X} + 1) ; } #----------------------------------------------------------------------------- sub get_text { my ($self) = @_ ; } #----------------------------------------------------------------------------- sub set_text { my ($self) = @_ ; } #----------------------------------------------------------------------------- sub edit { my ($self, $asciio) = @_ ; return unless $self->{EDITABLE} ; $self->display_box_edit_dialog() ; $self->setup($self->{ARROW_TYPE}, $self->{END_X}, $self->{END_Y}, $self->{EDITABLE}) ; } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.51.3/lib/App/Asciio/stripes/if_box.pm000444001750000144 1451612544473514 21325 0ustar00nadimusers000000000000 package App::Asciio::stripes::if_box ; use base App::Asciio::stripes::single_stripe ; use strict; use warnings; use List::Util qw(min max) ; use Readonly ; use Clone ; #----------------------------------------------------------------------------- sub new { my ($class, $element_definition) = @_ ; my $self = bless {}, __PACKAGE__ ; $self->setup ( $element_definition->{TEXT_ONLY}, 1, 1, $element_definition->{RESIZABLE}, $element_definition->{EDITABLE}, ) ; return $self ; } #----------------------------------------------------------------------------- sub setup { my ($self, $text_only, $end_x, $end_y, $resizable, $editable) = @_ ; # $end_x, $end_y are used if we want to keep a box size constant if the included text gets smaller # if_boxes automatically fit to their content (so far) so those variables are not used $text_only = '' unless defined $text_only ; my ($text_width, @lines) = (0) ; for my $line (split("\n", $text_only)) { $text_width = max($text_width, length($line)) ; push @lines, $line ; } my $number_of_lines = scalar(@lines) ; my $lines_to_add = ($number_of_lines + 1) % 2 ; # always odd unshift @lines, map {''} (1 .. $lines_to_add / 2) ; push @lines, map {''} (1 .. $lines_to_add / 2) ; $number_of_lines += $lines_to_add ; my $half_the_lines = int($number_of_lines / 2) ; my $extra_width = 2 + $half_the_lines ; my $extra_height = 2 ; my $text = ' ' x ($half_the_lines + 1). '.' . '-' x $text_width . '.' . "\n" ; my @top_lines = (splice @lines, 0, $number_of_lines / 2) ; my $left_indentation = $half_the_lines ; my $inside_indentation = 0 ; for my $line (@top_lines) { my $padding = ' ' x ($text_width - length($line)) ; $text .= ' ' x $left_indentation . '/ ' . ' ' x $inside_indentation . $line . $padding . ' ' x $inside_indentation. ' \\' . "\n" ; $left_indentation-- ; $inside_indentation++ ; } my $center_line = shift @lines || '' ; my $padding = ' ' x ($text_width - length($center_line)) ; $center_line = '( ' . ' ' x $inside_indentation . $center_line . $padding . ' ' x $inside_indentation . ' )' ; my $width = length($center_line) ; $text .= $center_line . "\n" ; $left_indentation = 1 ; $inside_indentation-- ; my @bottom_lines = @lines ; push @bottom_lines, '' for (1 .. scalar(@top_lines) - scalar(@bottom_lines)) ; for my $line (@bottom_lines) { my $padding = ' ' x ($text_width - length($line)) ; $text .= ' ' x $left_indentation . '\\ ' . ' ' x $inside_indentation . $line . $padding . ' ' x $inside_indentation . ' /' . "\n" ; $left_indentation++ ; $inside_indentation-- ; } $text .= ' ' x ($half_the_lines + 1) . q{'} . '-' x $text_width . q{'} . "\n" ; $self->set ( TEXT => $text, WIDTH => $width, HEIGHT => $number_of_lines + 2, TEXT_ONLY => $text_only, RESIZABLE => $resizable, EDITABLE => $editable, ) ; } #----------------------------------------------------------------------------- sub get_selection_action { my ($self, $x, $y) = @_ ; if ( ($x == $self->{WIDTH} - 1 && $y == $self->{HEIGHT} - 1) ) { 'resize' ; } else { 'move' ; } } #----------------------------------------------------------------------------- sub match_connector { my ($self, $x, $y) = @_ ; my $middle_width = int($self->{WIDTH} / 2) ; my $middle_height = int($self->{HEIGHT} / 2) ; if($x == $middle_width && $y == -1) { return {X => $x, Y => $y, NAME => 'top_center'} ; } elsif($x == $middle_width && $y == $self->{HEIGHT}) { return {X => $x, Y => $y, NAME => 'bottom_center'} ; } if($x == -1 && $y == $middle_height) { return {X => $x, Y => $y, NAME => 'left_center'} ; } elsif($x == $self->{WIDTH} && $y == $middle_height) { return {X => $x, Y => $y, NAME => 'right_center'} ; } elsif($x >= 0 && $x < $self->{WIDTH} && $y >= 0 && $y < $self->{HEIGHT}) { return {X => $middle_width, Y => -1, NAME => 'to_be_optimized'} ; } else { return ; } } #----------------------------------------------------------------------------- sub get_connection_points { my ($self) = @_ ; my $middle_width = int($self->{WIDTH} / 2) ; my $middle_height = int($self->{HEIGHT} / 2) ; return ( {X => $middle_width, Y => -1, NAME => 'top_center'}, {X => $middle_width, Y => $self->{HEIGHT}, NAME => 'bottom_center'}, {X => -1, Y => $middle_height, NAME => 'left_center'}, {X => $self->{WIDTH}, Y => $middle_height, NAME => 'right_center'}, ) ; } #----------------------------------------------------------------------------- sub get_named_connection { my ($self, $name) = @_ ; my $middle_width = int($self->{WIDTH} / 2) ; my $middle_height = int($self->{HEIGHT} / 2) ; if($name eq 'top_center') { return( {X => $middle_width, Y => -1, NAME => 'top_center'} ) ; } elsif($name eq 'bottom_center') { return( {X => $middle_width, Y => $self->{HEIGHT}, NAME => 'bottom_center'} ) ; } elsif($name eq 'left_center') { return {X => -1, Y => $middle_height, NAME => 'left_center'}, } elsif($name eq 'right_center') { return {X => $self->{WIDTH}, Y => $middle_height, NAME => 'right_center'}, } else { return ; } } #----------------------------------------------------------------------------- sub resize { my ($self, $reference_x, $reference_y, $new_x, $new_y) = @_ ; # if box is npt resizable return(0, 0, $self->{WIDTH}, $self->{HEIGHT}) ; #~ return(0, 0, $self->{WIDTH}, $self->{HEIGHT}) unless $self->{RESIZABLE} ; #~ my $new_end_x = $new_x ; #~ my $new_end_y = $new_y ; #~ if($new_end_x >= 0 && $new_end_y >= 0) #~ { #~ $self->setup($self->{TEXT_ONLY}, $new_end_x + 1, $new_end_y + 1, $self->{RESIZABLE}, $self->{EDITABLE}) ; #~ } #~ return(0, 0, $self->{WIDTH}, $self->{HEIGHT}) ; } #----------------------------------------------------------------------------- sub get_text { my ($self) = @_ ; return($self->{TEXT_ONLY}) ; } #----------------------------------------------------------------------------- sub set_text { my ($self, $text) = @_ ; $text = 'edit_me' if($text eq '') ; $self->setup($text, $self->{WIDTH}, $self->{HEIGHT}, $self->{RESIZABLE}, $self->{EDITABLE}) ; } #----------------------------------------------------------------------------- sub edit { my ($self, $asciio) = @_ ; return unless $self->{EDITABLE} ; my ($text) = $asciio->display_edit_dialog('asciio', $self->{TEXT_ONLY}) ; my $tab_as_space = $self->{TAB_AS_SPACES} || (' ' x 3) ; $text =~ s/\t/$tab_as_space/g ; $self->set_text($text) ; } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.51.3/lib/App/Asciio/stripes/section_wirl_arrow.pm000444001750000144 6040712544473514 23772 0ustar00nadimusers000000000000 package App::Asciio::stripes::section_wirl_arrow ; use base App::Asciio::stripes::stripes ; use strict; use warnings; use List::Util qw(min max) ; use Readonly ; use Clone ; use App::Asciio::stripes::wirl_arrow ; #----------------------------------------------------------------------------- # the idea is to reuse wirl arrow implementation as much as possible #----------------------------------------------------------------------------- Readonly my $DEFAULT_ARROW_TYPE => [ ['origin', '', '*', '', '', '', 1], ['up', '|', '|', '', '', '^', 1], ['down', '|', '|', '', '', 'v', 1], ['left', '-', '-', '', '', '<', 1], ['upleft', '|', '|', '.', '-', '<', 1], ['leftup', '-', '-', '\'', '|', '^', 1], ['downleft', '|', '|', '\'', '-', '<', 1], ['leftdown', '-', '-', '.', '|', 'v', 1], ['right', '-', '-','', '', '>', 1], ['upright', '|', '|', '.', '-', '>', 1], ['rightup', '-', '-', '\'', '|', '^', 1], ['downright', '|', '|', '\'', '-', '>', 1], ['rightdown', '-', '-', '.', '|', 'v', 1], ['45', '/', '/', '', '', '^', 1, ], ['135', '\\', '\\', '', '', 'v', 1, ], ['225', '/', '/', '', '', 'v', 1, ], ['315', '\\', '\\', '', '', '^', 1, ], ] ; # constants for connector overlays Readonly my $body_index => 2 ; Readonly my $connection_index => 3 ; Readonly my $up_index=> 1 ; Readonly my $left_index=> 3 ; Readonly my $leftup_index => 5 ; Readonly my $leftdown_index => 7 ; sub new { my ($class, $element_definition) = @_ ; my $self = bless {}, __PACKAGE__ ; $self->setup ( $element_definition->{ARROW_TYPE} || Clone::clone($DEFAULT_ARROW_TYPE), $element_definition->{POINTS}, $element_definition->{DIRECTION}, $element_definition->{ALLOW_DIAGONAL_LINES}, $element_definition->{EDITABLE}, $element_definition->{NOT_CONNECTABLE_START}, $element_definition->{NOT_CONNECTABLE_END}, ) ; return $self ; } #----------------------------------------------------------------------------- sub setup { my ($self, $arrow_type, $points, $direction, $allow_diagonal_lines, $editable, $not_connectable_start, $not_connectable_end) = @_ ; if('ARRAY' eq ref $points && @{$points} > 0) { my ($start_x, $start_y, $arrows) = (0, 0, []) ; my $points_offsets ; my $arrow_index = 0 ; # must have a numeric index or 'undo' won't work for my $point (@{$points}) { my ($x, $y, $point_direction) = @{$point} ; my $arrow = new App::Asciio::stripes::wirl_arrow ({ ARROW_TYPE => $arrow_type, END_X => $x - $start_x, END_Y => $y - $start_y, DIRECTION => $point_direction || $direction, ALLOW_DIAGONAL_LINES => $allow_diagonal_lines, EDITABLE => $editable, }) ; $points_offsets->[$arrow_index++] = [$start_x, $start_y] ; push @{$arrows}, $arrow ; ($start_x, $start_y) = ($x, $y) ; } $self->set ( POINTS_OFFSETS => $points_offsets, ARROWS => $arrows, # keep data to allow section insertion later ARROW_TYPE => $arrow_type, DIRECTION => $direction, ALLOW_DIAGONAL_LINES => $allow_diagonal_lines, EDITABLE => $editable, NOT_CONNECTABLE_START => $not_connectable_start, NOT_CONNECTABLE_END => $not_connectable_end, ) ; my ($width, $height) = $self->get_width_and_height() ; $self->set ( WIDTH => $width, HEIGHT => $height, ) ; } else { die "Bad 'section wirl arrow' defintion! Expecting points array." ; } } #----------------------------------------------------------------------------- my %diagonal_direction_to_overlay_character = ( (map {$_ => q{\\}} qw( down-right right-down up-left left-up)), (map {$_ => q{/}} qw( down-left left-down up-right right-up)), ) ; my %diagonal_non_diagonal_to_overlay_character = ( (map {$_ => q{.}} qw( down-right right-down up-left left-up)), (map {$_ => q{'}} qw( down-left left-down up-right right-up)), ) ; sub get_mask_and_element_stripes { my ($self) = @_ ; my @mask_and_element_stripes ; my $arrow_index = 0 ; for my $arrow(@{$self->{ARROWS}}) { push @mask_and_element_stripes, map { $_->{X_OFFSET} += $self->{POINTS_OFFSETS}[$arrow_index][0] ; $_->{Y_OFFSET} += $self->{POINTS_OFFSETS}[$arrow_index][1]; $_ ; } $arrow->get_mask_and_element_stripes() ; $arrow_index++ ; } # handle connections my ($previous_direction) = ($self->{ARROWS}[0]{DIRECTION} =~ /^([^-]+)/) ; my $previous_was_diagonal ; $arrow_index = 0 ; for my $arrow(@{$self->{ARROWS}}) { last if @{$self->{ARROWS}} == 1 ; my ($connection, $d1, $d2) ; if($arrow->{DIRECTION} =~ /^([^-]+)-([^-]+)$/) { ($d1, $d2) = ($1, $2) ; } else { $d1 = $arrow->{DIRECTION}; } if($self->{ALLOW_DIAGONAL_LINES} && $arrow->{WIDTH} == $arrow->{HEIGHT}) { # this section is diagonal if ( $previous_was_diagonal && ( $previous_was_diagonal eq $arrow->{DIRECTION} || (defined $d2 && $previous_was_diagonal eq "$d2-$d1") ) ) { # two diagonals going in the same direction $connection = $diagonal_direction_to_overlay_character{$arrow->{DIRECTION}} ; } else { # previous non diagonal or two diagonals not going in the same direction $connection = ($d1 eq 'up' || (defined $d2 && $d2 eq 'up')) ? q{'} : q{.} ; } $previous_was_diagonal = $arrow->{DIRECTION} ; } else { # straight or angled arrow if(defined $previous_was_diagonal) { if($arrow->{DIRECTION} =~ /^down/) { $connection = q{.} ; } elsif($arrow->{DIRECTION} =~ /^up/) { $connection = q{'} ; } else { $connection = $previous_was_diagonal =~ /down/ ? q{'} : q{.} ; } } else { if($previous_direction ne $d1) { if($d1 eq 'down') { $connection = $self->{ARROW_TYPE}[$leftdown_index][$connection_index] ; } elsif($d1 eq 'up') { $connection = $self->{ARROW_TYPE}[$leftup_index][$connection_index] ; } elsif($previous_direction eq 'down') { $connection = $self->{ARROW_TYPE}[$leftup_index][$connection_index] ; } elsif($previous_direction eq 'up') { $connection = $self->{ARROW_TYPE}[$leftdown_index][$connection_index] ; } else { $connection = $self->{ARROW_TYPE}[$left_index][$body_index] ; # for left and right, up down cases handled over } } } $previous_direction = defined $d2 ? $d2 : $d1 ; $previous_was_diagonal = undef ; } if($arrow_index != 0 && defined $connection) # first character of the first section is always right { # overlay the first character of this arrow push @mask_and_element_stripes, { X_OFFSET => $self->{POINTS_OFFSETS}[$arrow_index][0], Y_OFFSET => $self->{POINTS_OFFSETS}[$arrow_index][1], WIDTH => 1, HEIGHT => 1, TEXT => $connection, } ; } $arrow_index++ ; } return(@mask_and_element_stripes) ; } #----------------------------------------------------------------------------- sub get_selection_action { my ($self, $x, $y) = @_ ; my $action = 'move' ; my $arrow_index = 0 ; for my $arrow(@{$self->{ARROWS}}) { my ($start_connector, $end_connector) = $arrow->get_connector_points() ; $start_connector->{X} += $self->{POINTS_OFFSETS}[$arrow_index][0] ; $start_connector->{Y} += $self->{POINTS_OFFSETS}[$arrow_index][1] ; if($x == $start_connector->{X} && $y == $start_connector->{Y}) { $action = 'resize' ; last ; } $end_connector->{X} += $self->{POINTS_OFFSETS}[$arrow_index][0] ; $end_connector->{Y} += $self->{POINTS_OFFSETS}[$arrow_index][1] ; if($x == $end_connector->{X} && $y == $end_connector->{Y}) { $action = 'resize' ; last ; } $arrow_index++ ; } return $action ; } #----------------------------------------------------------------------------- sub allow_connection { my ($self, $which, $connect) = @_ ; if($which eq 'start') { $self->{NOT_CONNECTABLE_START} = !$connect ; } else { $self->{NOT_CONNECTABLE_END} = !$connect ; } } #----------------------------------------------------------------------------- sub is_connection_allowed { my ($self, $which) = @_ ; if($which eq 'start') { return(! $self->{NOT_CONNECTABLE_START}) ; } else { return(! $self->{NOT_CONNECTABLE_END}) ; } } #----------------------------------------------------------------------------- sub are_diagonals_allowed { my ($self, $allow) = @_ ; return $self->{ALLOW_DIAGONAL_LINES} ; } #----------------------------------------------------------------------------- sub allow_diagonals { my ($self, $allow) = @_ ; $self->{ALLOW_DIAGONAL_LINES} = $allow ; for my $arrow(@{$self->{ARROWS}}) { $arrow->{ALLOW_DIAGONAL_LINES} = $allow ; } } #----------------------------------------------------------------------------- sub get_connector_points { my ($self) = @_ ; my(@all_connector_points) = $self->get_all_points() ; my(@connector_points) ; push @connector_points, $all_connector_points[0] unless $self->{NOT_CONNECTABLE_START} ; push @connector_points, $all_connector_points[-1] unless $self->{NOT_CONNECTABLE_END} ; return(@connector_points) ; } sub get_extra_points { my ($self) = @_ ; my(@all_connector_points) = $self->get_all_points() ; shift @all_connector_points unless $self->{NOT_CONNECTABLE_START} ; pop @all_connector_points unless $self->{NOT_CONNECTABLE_END} ; return(@all_connector_points) ; } sub get_all_points { my ($self) = @_ ; my(@connector_points) ; my $arrow_index = 0 ; for my $arrow(@{$self->{ARROWS}}) { my ($start_connector, $end_connector) = $arrow->get_connector_points() ; if($arrow == $self->{ARROWS}[0]) { $start_connector->{X} += $self->{POINTS_OFFSETS}[$arrow_index][0] ; $start_connector->{Y} += $self->{POINTS_OFFSETS}[$arrow_index][1] ; $start_connector->{NAME} .= "section_$arrow_index" ; push @connector_points, $start_connector ; } $end_connector->{X} += $self->{POINTS_OFFSETS}[$arrow_index][0] ; $end_connector->{Y} += $self->{POINTS_OFFSETS}[$arrow_index][1] ; $end_connector->{NAME} .= "section_$arrow_index" ; push @connector_points, $end_connector ; $arrow_index++ ; } return(@connector_points) ; } #----------------------------------------------------------------------------- sub get_named_connection { my ($self, $name) = @_ ; my $connection ; my $arrow_index = 0 ; for my $arrow(@{$self->{ARROWS}}) { my ($start_connector, $end_connector) = $arrow->get_connector_points() ; if($arrow == $self->{ARROWS}[0]) { $start_connector->{NAME} .= "section_$arrow_index" ; if($name eq $start_connector->{NAME}) { $start_connector->{X} += $self->{POINTS_OFFSETS}[$arrow_index][0] ; $start_connector->{Y} += $self->{POINTS_OFFSETS}[$arrow_index][1] ; $connection = $start_connector ; last ; } } $end_connector->{NAME} .= "section_$arrow_index" ; if($name eq $end_connector->{NAME}) { $end_connector->{X} += $self->{POINTS_OFFSETS}[$arrow_index][0] ; $end_connector->{Y} += $self->{POINTS_OFFSETS}[$arrow_index][1] ; $connection = $end_connector ; last ; } $arrow_index++ ; } return $connection ; } #----------------------------------------------------------------------------- sub move_connector { my ($self, $connector_name, $x_offset, $y_offset, $hint) = @_ ; my $connection = $self->get_named_connection($connector_name) ; (my $no_section_connetor_name = $connector_name) =~ s/section_.*// ; if($connection) { my ($x_offset, $y_offset, $width, $height, undef) = $self->resize ( $connection->{X}, $connection->{Y}, $connection->{X} + $x_offset, $connection->{Y} + $y_offset, $hint, #~ [$no_section_connetor_name, $connector_name], [$connector_name, $no_section_connetor_name], ) ; return ( $x_offset, $y_offset, $width, $height, $self->get_named_connection($connector_name) ) ; } else { die "unknown connector '$connector_name'!\n" ; } } #----------------------------------------------------------------------------- sub resize { my ($self, $reference_x, $reference_y, $new_x, $new_y, $hint, $connector_name_array) = @_ ; Readonly my $MULTI_WIRL_CONNECTOR_NAME_INDEX => 0 ; Readonly my $WIRL_CONNECTOR_NAME_INDEX => 1 ; my ($start_element, $start_element_index, $end_element, $end_element_index) ; # find elements connected by the connector if(defined $connector_name_array) { ($start_element, $start_element_index, $end_element, $end_element_index, $connector_name_array) = $self->find_elements_for_connector_named($connector_name_array) ; } else { ($start_element, $start_element_index, $end_element, $end_element_index, $connector_name_array) = $self->find_elements_for_connector_at($reference_x, $reference_y) ; } my ($start_x_offset, $start_y_offset) = (0, 0) ; if(defined $start_element) { my $is_start ; if(defined $connector_name_array) { if ( $connector_name_array->[$WIRL_CONNECTOR_NAME_INDEX] eq 'start' || $connector_name_array->[$MULTI_WIRL_CONNECTOR_NAME_INDEX] eq 'startsection_0' ) { $is_start++ ; } } else { if($reference_x == 0 && $reference_y == 0) { $is_start++ ; } } if($is_start) { #~ print "Moving start connector\n" ; ($start_x_offset, $start_y_offset) = $start_element->resize ( 0, 0, $new_x, $new_y, $hint, $connector_name_array->[$WIRL_CONNECTOR_NAME_INDEX] ) ; my $arrow_index = 0 ; for my $arrow(@{$self->{ARROWS}}) { # offsets all other wirl_arrow start offsets if($arrow == $start_element) { } else { $self->{POINTS_OFFSETS}[$arrow_index][0] -= $start_x_offset ; $self->{POINTS_OFFSETS}[$arrow_index][1] -= $start_y_offset ; } $arrow_index++ ; } } else { my $start_element_x_offset = $self->{POINTS_OFFSETS}[$start_element_index][0] ; my $start_element_y_offset = $self->{POINTS_OFFSETS}[$start_element_index][1] ; my ($x_offset, $y_offset) = $start_element ->resize ( $reference_x - $start_element_x_offset, $reference_y - $start_element_y_offset, $new_x - $start_element_x_offset, $new_y - $start_element_y_offset, $hint, $connector_name_array->[$WIRL_CONNECTOR_NAME_INDEX] ) ; $self->{POINTS_OFFSETS}[$start_element_index][0] += $x_offset ; $self->{POINTS_OFFSETS}[$start_element_index][1] += $y_offset ; if(defined $end_element) { my ($x_offset, $y_offset) = $end_element->resize(0, 0, $new_x - $reference_x, $new_y - $reference_y) ; $self->{POINTS_OFFSETS}[$end_element_index][0] += $x_offset ; $self->{POINTS_OFFSETS}[$end_element_index][1] += $y_offset ; } } } my ($width, $height) = $self->get_width_and_height() ; $self->set(WIDTH => $width, HEIGHT => $height) ; return($start_x_offset, $start_y_offset, $width, $height, $connector_name_array) ; } sub find_elements_for_connector_at { my ($self, $reference_x, $reference_y) = @_ ; my ($start_element, $start_element_index, $end_element, $end_element_index, $connector_name, $wirl_connector_name) ; my $arrow_index = 0 ; for my $arrow(@{$self->{ARROWS}}) { my ($start_connector, $end_connector) = $arrow->get_connector_points() ; if($reference_x == 0 && $reference_y == 0) { ($start_element, $start_element_index) = ($arrow, $arrow_index) ; $wirl_connector_name = $start_connector->{NAME} ; $connector_name = $wirl_connector_name . "section_$arrow_index" ; last ; } if(defined $start_element) { ($end_element, $end_element_index) = ($arrow, $arrow_index) ; last ; } if ( $reference_x == $end_connector->{X} + $self->{POINTS_OFFSETS}[$arrow_index][0] && $reference_y == $end_connector->{Y} + $self->{POINTS_OFFSETS}[$arrow_index][1] ) { ($start_element, $start_element_index) = ($arrow, $arrow_index) ; $wirl_connector_name = $end_connector->{NAME} ; $connector_name = $wirl_connector_name . "section_$arrow_index" ; } $arrow_index++ ; } return($start_element, $start_element_index, $end_element, $end_element_index, [$connector_name, $wirl_connector_name]) } sub find_elements_for_connector_named { my ($self, $connector_name_array) = @_ ; my ($connector_name, $wirl_connector_name) = @{$connector_name_array} ; my ($start_element, $start_element_index, $end_element, $end_element_index) ; my $arrow_index = 0 ; for my $arrow(@{$self->{ARROWS}}) { my ($start_connector, $end_connector) = $arrow->get_connector_points() ; if($connector_name eq $start_connector->{NAME} . "section_$arrow_index" ) { ($start_element, $start_element_index) = ($arrow, $arrow_index) ; last ; } if(defined $start_element) { ($end_element, $end_element_index) = ($arrow, $arrow_index) ; last ; } if($connector_name eq $end_connector->{NAME} . "section_$arrow_index") { ($start_element, $start_element_index) = ($arrow, $arrow_index) ; } $arrow_index++ ; } return($start_element, $start_element_index, $end_element, $end_element_index, $connector_name_array) ; } #----------------------------------------------------------------------------- sub get_number_of_sections { my ($self) = @_ ; return scalar(@{$self->{ARROWS}}) ; } #----------------------------------------------------------------------------- sub get_section_direction { my ($self, $section_index) = @_ ; if(exists($self->{ARROWS}[$section_index])) { return $self->{ARROWS}[$section_index]->get_direction() ; } else { return ; } } #----------------------------------------------------------------------------- sub insert_section { my ($self, $x_offset, $y_offset) = @_ ; my $index = 0 ; for my $arrow (@{$self->{ARROWS}}) { if ( $self->is_over_element ( $arrow, $x_offset, $y_offset, 0, @{$self->{POINTS_OFFSETS}[$index]} ) ) { my ($original_arrow_end_x, $original_arrow_end_y) = ($arrow->{END_X}, $arrow->{END_Y}) ; my $first_section = new App::Asciio::stripes::wirl_arrow ({ END_X => $x_offset - $self->{POINTS_OFFSETS}[$index][0], END_Y => $y_offset - $self->{POINTS_OFFSETS}[$index][1], ARROW_TYPE => $arrow->{ARROW_TYPE}, DIRECTION => $arrow->{DIRECTION}, ALLOW_DIAGONAL_LINES => $arrow->{ALLOW_DIAGONAL_LINES}, EDITABLE => $arrow->{EDITABLE}, }) ; $self->{ARROWS}[$index] = $first_section ; my $new_section = new App::Asciio::stripes::wirl_arrow ({ END_X => ($self->{POINTS_OFFSETS}[$index][0] + $original_arrow_end_x) - $x_offset, END_Y => ($self->{POINTS_OFFSETS}[$index][1] + $original_arrow_end_y) - $y_offset, ARROW_TYPE => $arrow->{ARROW_TYPE}, DIRECTION => $arrow->{DIRECTION}, ALLOW_DIAGONAL_LINES => $arrow->{ALLOW_DIAGONAL_LINES}, EDITABLE => $arrow->{EDITABLE}, }) ; splice @{$self->{ARROWS}}, $index + 1, 0, $new_section ; splice @{$self->{POINTS_OFFSETS}}, $index + 1, 0, [$x_offset, $y_offset] ; last ; } $index++ ; } } #----------------------------------------------------------------------------- sub prepend_section { my ($self, $extend_x, $extend_y) = @_ ; my $arrow = new App::Asciio::stripes::wirl_arrow ({ END_X => -$extend_x, END_Y => -$extend_y, ARROW_TYPE => $self->{ARROW_TYPE}, DIRECTION => $self->{DIRECTION}, ALLOW_DIAGONAL_LINES => $self->{ALLOW_DIAGONAL_LINES}, EDITABLE => $self->{EDITABLE}, }) ; my $arrow_index = 0 ; for my $arrow(@{$self->{ARROWS}}) { $self->{POINTS_OFFSETS}[$arrow_index][0] += -$extend_x ; $self->{POINTS_OFFSETS}[$arrow_index][1] += -$extend_y ; $arrow_index++ ; } unshift @{$self->{POINTS_OFFSETS}}, [0, 0] ; unshift @{$self->{ARROWS}}, $arrow ; my ($width, $height) = $self->get_width_and_height() ; $self->set(WIDTH => $width, HEIGHT => $height,) ; } sub append_section { my ($self, $extend_x, $extend_y) = @_ ; my $last_point = $self->get_points()->[-1] ; my $arrow = new App::Asciio::stripes::wirl_arrow ({ END_X => $extend_x - $last_point->[0], END_Y => $extend_y - $last_point->[1], ARROW_TYPE => $self->{ARROW_TYPE}, DIRECTION => $self->{DIRECTION}, ALLOW_DIAGONAL_LINES => $self->{ALLOW_DIAGONAL_LINES}, EDITABLE => $self->{EDITABLE}, }) ; my ($start_x, $start_y) = @{$self->{POINTS_OFFSETS}[-1]} ; my ($start_connector, $end_connector) = $self->{ARROWS}[-1]->get_connector_points() ; $start_x += $end_connector->{X} ; $start_y += $end_connector->{Y} ; push @{$self->{POINTS_OFFSETS}}, [$start_x, $start_y] ; push @{$self->{ARROWS}}, $arrow ; my ($width, $height) = $self->get_width_and_height() ; $self->set(WIDTH => $width, HEIGHT => $height,) ; } #----------------------------------------------------------------------------- sub remove_last_section { my ($self) = @_ ; return if @{$self->{ARROWS}} == 1 ; pop @{$self->{POINTS_OFFSETS}} ; pop @{$self->{ARROWS}} ; my ($width, $height) = $self->get_width_and_height() ; $self->set(WIDTH => $width, HEIGHT => $height,) ; } #----------------------------------------------------------------------------- sub remove_first_section { my ($self) = @_ ; return(0, 0) if @{$self->{ARROWS}} == 1 ; my $second_arrow_x_offset = $self->{POINTS_OFFSETS}[1][0] ; my $second_arrow_y_offset = $self->{POINTS_OFFSETS}[1][1] ; shift @{$self->{POINTS_OFFSETS}} ; shift @{$self->{ARROWS}} ; my $arrow_index = 0 ; for my $arrow(@{$self->{ARROWS}}) { $self->{POINTS_OFFSETS}[$arrow_index][0] -= $second_arrow_x_offset ; $self->{POINTS_OFFSETS}[$arrow_index][1] -= $second_arrow_y_offset ; $arrow_index++ ; } my ($width, $height) = $self->get_width_and_height() ; $self->set(WIDTH => $width, HEIGHT => $height,) ; return($second_arrow_x_offset, $second_arrow_y_offset) ; } #----------------------------------------------------------------------------- sub change_section_direction { my ($self, $x, $y) = @_ ; if(1 == @{$self->{ARROWS}}) { my $direction = $self->{ARROWS}[0]->get_direction() ; if($direction =~ /(.*)-(.*)/) { $self->{ARROWS}[0]->resize(0, 0, 0, 0, "$2-$1") ; } } else { my $index = 0 ; for my $arrow(@{$self->{ARROWS}}) { if ( $self->is_over_element ( $arrow, $x, $y, 0, @{$self->{POINTS_OFFSETS}[$index]} ) ) { my $direction = $arrow->get_direction() ; if($direction =~ /(.*)-(.*)/) { $arrow->resize(0, 0, 0, 0, "$2-$1") ; } last ; } $index++ ; } } } sub is_over_element { my ($self, $element, $x, $y, $field, $element_offset_x, $element_offset_y, ) = @_ ; die "Error: 'is_over_element' needs position!" unless defined $x && defined $y ; $field ||= 0 ; my $is_under = 0 ; for my $mask_strip ($element->get_mask_and_element_stripes()) { my $stripe_x = $element_offset_x + $mask_strip->{X_OFFSET} ; my $stripe_y = $element_offset_y + $mask_strip->{Y_OFFSET} ; if ( $stripe_x - $field <= $x && $x < $stripe_x + $mask_strip->{WIDTH} + $field && $stripe_y - $field <= $y && $y < $stripe_y + $mask_strip->{HEIGHT} + $field ) { $is_under++ ; last ; } } return($is_under) ; } #----------------------------------------------------------------------------- sub get_width_and_height { my ($self) = @_ ; my ($smallest_x, $biggest_x, $smallest_y, $biggest_y) = (0, 0, 0, 0) ; my $arrow_index = 0 ; for my $start_point (@{$self->{POINTS_OFFSETS}}) { my ($x, $y) = @{$start_point} ; my ($start_connector, $end_connector) = $self->{ARROWS}[$arrow_index]->get_connector_points() ; $x += $end_connector->{X} ; $y += $end_connector->{Y} ; $smallest_x = min($smallest_x, $x) ; $smallest_y = min($smallest_y, $y) ; $biggest_x = max($biggest_x, $x) ; $biggest_y = max($biggest_y, $y) ; $arrow_index++ ; } return(($biggest_x - $smallest_x) + 1, ($biggest_y - $smallest_y) + 1) ; } #----------------------------------------------------------------------------- sub get_arrow_type { my ($self) = @_ ; return($self->{ARROW_TYPE}) ; } #----------------------------------------------------------------------------- sub set_arrow_type { my ($self, $arrow_type) = @_ ; $self->setup($arrow_type, $self->get_points(), $self->{DIRECTION}, $self->{ALLOW_DIAGONAL_LINES}, $self->{EDITABLE}) ; } #----------------------------------------------------------------------------- sub get_points { my ($self) = @_ ; my @points ; my $arrow_index = 0 ; for my $point_offset (@{$self->{POINTS_OFFSETS}}) { my ($x_offset, $y_offset) = @{$point_offset} ; my ($start_connector, $end_connector, $direction) = ( $self->{ARROWS}[$arrow_index]->get_connector_points(), $self->{ARROWS}[$arrow_index]->get_direction() ) ; push @points, [$x_offset + $end_connector->{X}, $y_offset + $end_connector->{Y}, $direction] ; $arrow_index++ ; } return \@points ; } #----------------------------------------------------------------------------- sub edit { my ($self) = @_ ; return unless $self->{EDITABLE} ; # add section # remove section # handle offset array } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.51.3/lib/App/Asciio/stripes/stripes.pm000444001750000144 1016212544473514 21541 0ustar00nadimusers000000000000 package App::Asciio::stripes::stripes ; use strict; use warnings; use List::MoreUtils qw(minmax) ; sub new { my ($class, $element_definition) = @_ ; my @stripes ; my ($total_width, $total_height) = (0, 0) ; for my $stripe (@{$element_definition->{STRIPES}}) { my $text = $stripe->{TEXT} ; my $width = 0 ; map {$width = $width < length($_) ? length($_) : $width} split("\n", $text) ; my $height = ($text =~ tr[\n][\n]) + 1 ; push @stripes, { TEXT => $text, X_OFFSET => $stripe->{X_OFFSET}, Y_OFFSET => $stripe->{Y_OFFSET}, WIDTH => $width, HEIGHT => $height , } ; (undef, $total_width) = minmax($total_width, $stripe->{X_OFFSET} + $width) ; (undef, $total_height) = minmax($total_height, $stripe->{Y_OFFSET} + $height) ; } return bless { STRIPES => \@stripes, WIDTH => $total_width, HEIGHT => $total_height, }, __PACKAGE__ ; } #--------------------------------------------------------------------------- sub get_mask_and_element_stripes { my ($self) = @_ ; my @elements_stripes ; for my $stripe (@{$self->{STRIPES}}) { push @elements_stripes, {X_OFFSET => $stripe->{X_OFFSET}, Y_OFFSET => $stripe->{Y_OFFSET}, WIDTH => $stripe->{WIDTH}, HEIGHT => $stripe->{HEIGHT}, TEXT => $stripe->{TEXT}} ; } return(@elements_stripes) ; } #----------------------------------------------------------------------------- sub get_size { my ($self) = @_ ; return($self->{WIDTH}, $self->{HEIGHT}) ; } #----------------------------------------------------------------------------- sub resize { my ($self, $reference_x, $reference_y, $new_x, $new_y) = @_ ; return(0, 0, $self->{WIDTH}, $self->{HEIGHT}) ; } #----------------------------------------------------------------------------- sub get_action_menu_entries { } #----------------------------------------------------------------------------- sub get_selection_action { 'move' ; } #----------------------------------------------------------------------------- sub get_colors { my ($self) = @_ ; return $self->{COLORS}{BACKGROUND}, $self->{COLORS}{FOREGROUND} ; } #----------------------------------------------------------------------------- sub set_background_color { my ($self, $background_color) = @_ ; $self->{COLORS}{BACKGROUND} = $background_color ; } #----------------------------------------------------------------------------- sub set_foreground_color { my ($self, $foreground_color) = @_ ; $self->{COLORS}{FOREGROUND} = $foreground_color ; } #----------------------------------------------------------------------------- sub set_colors { my ($self, $background_color, $foreground_color) = @_ ; $self->{COLORS}{BACKGROUND} = $background_color ; $self->{COLORS}{FOREGROUND} = $foreground_color ; } #----------------------------------------------------------------------------- sub get_text { } #----------------------------------------------------------------------------- sub set_text { } #----------------------------------------------------------------------------- sub edit { } #----------------------------------------------------------------------------- sub match_connector { } #----------------------------------------------------------------------------- sub get_connector_points { } sub get_connection_points { } sub get_extra_points { } #----------------------------------------------------------------------------- sub get_named_connection { } #----------------------------------------------------------------------------- sub move_connector { } #----------------------------------------------------------------------------- sub is_autoconnect_enabled { my ($self) = @_ ; return ! $self->{AUTOCONNECT_DISABLED} ; } #----------------------------------------------------------------------------- sub enable_autoconnect { my ($self, $enable) = @_ ; $self->{AUTOCONNECT_DISABLED} = !$enable ; } #----------------------------------------------------------------------------- sub set { # set fields in the hash my ($self, %key_values) = @_ ; while (my ($key, $value) = each %key_values) { #~ print "setting $key, $value\n" ; $self->{$key} = ${value} ; } } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.51.3/lib/App/Asciio/GTK000755001750000144 012544473514 16271 5ustar00nadimusers000000000000App-Asciio-1.51.3/lib/App/Asciio/GTK/Asciio.pm000444001750000144 3566012544473514 20225 0ustar00nadimusers000000000000 package App::Asciio::GTK::Asciio ; use base qw(App::Asciio) ; $|++ ; use strict; use warnings; use Glib ':constants'; use Gtk2 -init; use Gtk2::Gdk::Keysyms ; use App::Asciio::GTK::Asciio::stripes::editable_arrow2; use App::Asciio::GTK::Asciio::stripes::wirl_arrow ; use App::Asciio::GTK::Asciio::stripes::editable_box2; use App::Asciio::GTK::Asciio::Dialogs ; use App::Asciio::GTK::Asciio::Menues ; #----------------------------------------------------------------------------- our $VERSION = '0.01' ; #----------------------------------------------------------------------------- =head1 NAME =cut sub new { my ($class, $width, $height) = @_ ; my $self = App::Asciio::new($class) ; bless $self, $class ; $self->{KEYS}{K} = {%Gtk2::Gdk::Keysyms} ; $self->{KEYS}{C}= {map{$self ->{KEYS}{K}{$_} => $_} keys %{$self->{KEYS}{K}}} ; my $drawing_area = Gtk2::DrawingArea->new; $self->{widget} = $drawing_area ; $drawing_area->can_focus(TRUE) ; $drawing_area->signal_connect(configure_event => \&configure_event, $self); $drawing_area->signal_connect(expose_event => \&expose_event, $self); $drawing_area->signal_connect(motion_notify_event => \&motion_notify_event, $self); $drawing_area->signal_connect(button_press_event => \&button_press_event, $self); $drawing_area->signal_connect(button_release_event => \&button_release_event, $self); $drawing_area->signal_connect(key_press_event => \&key_press_event, $self); $drawing_area->set_events ([qw/ exposure-mask leave-notify-mask button-press-mask button-release-mask pointer-motion-mask key-press-mask key-release-mask /]); $self->event_options_changed() ; return($self) ; } #----------------------------------------------------------------------------- sub destroy { my ($self) = @_; $self->{widget}->get_toplevel()->destroy() ; } #----------------------------------------------------------------------------- sub set_title { my ($self, $title) = @_; $self->SUPER::set_title($title) ; if(defined $title) { $self->{widget}->get_toplevel()->set_title($title . ' - asciio') ; } } #----------------------------------------------------------------------------- sub set_font { my ($self, $font_family, $font_size) = @_; $self->SUPER::set_font($font_family, $font_size) ; $self->{widget}->modify_font ( Gtk2::Pango::FontDescription->from_string ( $self->{FONT_FAMILY} . ' ' . $self->{FONT_SIZE} ) ); } #----------------------------------------------------------------------------- sub update_display { my ($self) = @_; $self->SUPER::update_display() ; my $widget = $self->{widget} ; $widget->queue_draw_area(0, 0, $widget->allocation->width,$widget->allocation->height); } #----------------------------------------------------------------------------- sub configure_event { my ($widget, $event, $self) = @_; $self->{PIXMAP} = Gtk2::Gdk::Pixmap->new ( $widget->window, $widget->allocation->width, $widget->allocation->height, -1 ); $self->{WINDOW_SIZE} = [$widget->allocation->width, $widget->allocation->height] ; $self->{PIXMAP}->draw_rectangle ( $widget->get_style->base_gc ($widget->state), TRUE, 0, 0, $widget->allocation->width, $widget->allocation->height ); return TRUE; } #----------------------------------------------------------------------------- sub expose_event { my ($widget, $event, $self) = @_; my $gc = Gtk2::Gdk::GC->new($self->{PIXMAP}); # draw background $gc->set_foreground($self->get_color('background')); $self->{PIXMAP}->draw_rectangle ( $gc, TRUE, 0, 0, $widget->allocation->width, $widget->allocation->height ); my ($character_width, $character_height) = $self->get_character_size() ; my ($widget_width, $widget_height) = $self->{PIXMAP}->get_size(); if($self->{DISPLAY_GRID}) { $gc->set_foreground($self->get_color('grid')); for my $horizontal (0 .. ($widget_height/$character_height) + 1) { $self->{PIXMAP}->draw_line ( $gc, 0, $horizontal * $character_height, $widget_width, $horizontal * $character_height ); } for my $vertical(0 .. ($widget_width/$character_width) + 1) { $self->{PIXMAP}->draw_line ( $gc, $vertical * $character_width, 0, $vertical * $character_width, $widget_height ); } } # draw elements for my $element (@{$self->{ELEMENTS}}) { my ($background_color, $foreground_color) = $element->get_colors() ; if($self->is_element_selected($element)) { if(exists $element->{GROUP} and defined $element->{GROUP}[-1]) { $background_color = $self->get_color ( $self->{COLORS}{group_colors}[$element->{GROUP}[-1]{GROUP_COLOR}][0] ) ; } else { $background_color = $self->get_color('selected_element_background'); } } else { if(defined $background_color) { $background_color = $self->get_color($background_color) ; } else { if(exists $element->{GROUP} and defined $element->{GROUP}[-1]) { $background_color = $self->get_color ( $self->{COLORS}{group_colors}[$element->{GROUP}[-1]{GROUP_COLOR}][1] ) ; } else { $background_color = $self->get_color('element_background') ; } } } $foreground_color = defined $foreground_color ? $self->get_color($foreground_color) : $self->get_color('element_foreground') ; $gc->set_foreground($foreground_color); for my $mask_and_element_strip ($element->get_mask_and_element_stripes()) { $gc->set_foreground($background_color); $self->{PIXMAP}->draw_rectangle ( $gc, $self->{OPAQUE_ELEMENTS}, ($element->{X} + $mask_and_element_strip->{X_OFFSET}) * $character_width, ($element->{Y} + $mask_and_element_strip->{Y_OFFSET}) * $character_height, $mask_and_element_strip->{WIDTH} * $character_width, $mask_and_element_strip->{HEIGHT} * $character_height, ); $gc->set_foreground($foreground_color); my $layout = $widget->create_pango_layout($mask_and_element_strip->{TEXT}) ; my ($text_width, $text_height) = $layout->get_pixel_size; $self->{PIXMAP}->draw_layout ( $gc, ($element->{X} + $mask_and_element_strip->{X_OFFSET}) * $character_width, ($element->{Y} + $mask_and_element_strip->{Y_OFFSET}) * $character_height, $layout ); } } # draw ruler lines for my $line (@{$self->{RULER_LINES}}) { my $color = Gtk2::Gdk::Color->new( map {$_ * 257} @{$line->{COLOR} }) ; $self->{widget}->get_colormap->alloc_color($color,TRUE,TRUE) ; $gc->set_foreground($color); if($line->{TYPE} eq 'VERTICAL') { $self->{PIXMAP}->draw_line ( $gc, $line->{POSITION} * $character_width, 0, $line->{POSITION} * $character_width, $widget_height ); } else { $self->{PIXMAP}->draw_line ( $gc, 0, $line->{POSITION} * $character_height, $widget_width, $line->{POSITION} * $character_height ); } } # draw connections my (%connected_connections, %connected_connectors) ; for my $connection (@{$self->{CONNECTIONS}}) { my $draw_connection ; my $connector ; if($self->is_over_element($connection->{CONNECTED}, $self->{MOUSE_X}, $self->{MOUSE_Y}, 1)) { $draw_connection++ ; $connector = $connection->{CONNECTED}->get_named_connection($connection->{CONNECTOR}{NAME}) ; $connected_connectors{$connection->{CONNECTED}}{$connector->{X}}{$connector->{Y}}++ ; } if($self->is_over_element($connection->{CONNECTEE}, $self->{MOUSE_X}, $self->{MOUSE_Y}, 1)) { $draw_connection++ ; my $connectee_connection = $connection->{CONNECTEE}->get_named_connection($connection->{CONNECTION}{NAME}) ; if($connectee_connection) { $connected_connectors{$connection->{CONNECTEE}}{$connectee_connection->{X}}{$connectee_connection->{Y}}++ ; } } if($draw_connection) { $gc->set_foreground($self->get_color('connection')); $connector ||= $connection->{CONNECTED}->get_named_connection($connection->{CONNECTOR}{NAME}) ; $self->{PIXMAP}->draw_rectangle ( $gc, FALSE, ($connector->{X} + $connection->{CONNECTED}{X}) * $character_width, ($connector->{Y} + $connection->{CONNECTED}{Y}) * $character_height, $character_width, $character_height ); } } # draw connectors and connection points for my $element (grep {$self->is_over_element($_, $self->{MOUSE_X}, $self->{MOUSE_Y}, 1)} @{$self->{ELEMENTS}}) { $gc->set_foreground($self->get_color('connector_point')); for my $connector ($element->get_connector_points()) { next if exists $connected_connectors{$element}{$connector->{X}}{$connector->{Y}} ; $self->{PIXMAP}->draw_rectangle ( $gc, FALSE, ($element->{X} + $connector->{X}) * $character_width, ($connector->{Y} + $element->{Y}) * $character_height, $character_width, $character_height ); } $gc->set_foreground($self->get_color('connection_point')); for my $connection_point ($element->get_connection_points()) { next if exists $connected_connections{$element}{$connection_point->{X}}{$connection_point->{Y}} ; $self->{PIXMAP}->draw_rectangle # little box ( $gc, TRUE, (($connection_point->{X} + $element->{X}) * $character_width) + ($character_width / 3), (($connection_point->{Y} + $element->{Y}) * $character_height) + ($character_height / 3), $character_width / 3 , $character_height / 3 ); } for my $extra_point ($element->get_extra_points()) { if(exists $extra_point ->{COLOR}) { $gc->set_foreground($self->get_color($extra_point ->{COLOR})); } else { $gc->set_foreground($self->get_color('extra_point')); } $self->{PIXMAP}->draw_rectangle ( $gc, FALSE, (($extra_point ->{X} + $element->{X}) * $character_width), (($extra_point ->{Y} + $element->{Y}) * $character_height), $character_width, $character_height ); } } # draw new connections for my $new_connection (@{$self->{NEW_CONNECTIONS}}) { $gc->set_foreground($self->get_color('new_connection')); my $end_connection = $new_connection->{CONNECTED}->get_named_connection($new_connection->{CONNECTOR}{NAME}) ; $self->{PIXMAP}->draw_rectangle ( $gc, FALSE, ($end_connection->{X} + $new_connection->{CONNECTED}{X}) * $character_width , ($end_connection->{Y} + $new_connection->{CONNECTED}{Y}) * $character_height , $character_width, $character_height ); } delete $self->{NEW_CONNECTIONS} ; # draw selection rectangle if(defined $self->{SELECTION_RECTANGLE}{END_X}) { my $start_x = $self->{SELECTION_RECTANGLE}{START_X} * $character_width ; my $start_y = $self->{SELECTION_RECTANGLE}{START_Y} * $character_height ; my $width = ($self->{SELECTION_RECTANGLE}{END_X} - $self->{SELECTION_RECTANGLE}{START_X}) * $character_width ; my $height = ($self->{SELECTION_RECTANGLE}{END_Y} - $self->{SELECTION_RECTANGLE}{START_Y}) * $character_height; if($width < 0) { $width *= -1 ; $start_x -= $width ; } if($height < 0) { $height *= -1 ; $start_y -= $height ; } $gc->set_foreground($self->get_color('selection_rectangle')) ; $self->{PIXMAP}->draw_rectangle($gc, FALSE,$start_x, $start_y, $width, $height); delete $self->{SELECTION_RECTANGLE}{END_X} ; } $widget->window->draw_drawable ( $widget->style->fg_gc($widget->state), $self->{PIXMAP}, $event->area->x, $event->area->y, $event->area->x, $event->area->y, $event->area->width, $event->area->height ); return TRUE; } #----------------------------------------------------------------------------- sub get_key_modifiers { my ($event) = @_ ; my $key_modifiers = $event->state() ; my $modifiers = $key_modifiers =~ /control-mask/ ? 'C' :0 ; $modifiers .= $key_modifiers =~ /mod1-mask/ ? 'A' :0 ; $modifiers .= $key_modifiers =~ /shift-mask/ ? 'S' :0 ; return($modifiers) ; } #----------------------------------------------------------------------------- sub button_release_event { my ($widget, $event, $self) = @_ ; $self->SUPER::button_release_event($self->create_asciio_event($event)) ; } #----------------------------------------------------------------------------- sub create_asciio_event { my ($self, $event) = @_ ; my $asciio_event = { TYPE => $event->type(), STATE => $event->state() , MODIFIERS => get_key_modifiers($event), BUTTON => -1, KEY_VALUE => -1, COORDINATES => [-1, -1], } ; $asciio_event->{BUTTON} = $event->button() if ref $event eq 'Gtk2::Gdk::Event::Button' ; if ( ref $event eq "Gtk2::Gdk::Event::Motion" || ref $event eq "Gtk2::Gdk::Event::Button" ) { $asciio_event->{COORDINATES} = [$self->closest_character($event->coords())] ; } $asciio_event->{KEY_VALUE} = $event->keyval() if ref $event eq "Gtk2::Gdk::Event::Key" ; return $asciio_event ; } #----------------------------------------------------------------------------- sub button_press_event { #~ print "button_press_event\n" ; my ($widget, $event, $self) = @_ ; my $asciio_event = $self->create_asciio_event($event) ; $self->SUPER::button_press_event($asciio_event, $event) ; } #----------------------------------------------------------------------------- sub motion_notify_event { my ($widget, $event, $self) = @_ ; my $asciio_event = $self->create_asciio_event($event) ; $self->SUPER::motion_notify_event($asciio_event) ; } #----------------------------------------------------------------------------- sub key_press_event { my ($widget, $event, $self)= @_; my $asciio_event = $self->create_asciio_event($event) ; $self->SUPER::key_press_event($asciio_event) ; } #----------------------------------------------------------------------------- sub get_character_size { my ($self) = @_ ; if(exists $self->{USER_CHARACTER_WIDTH}) { return ($self->{USER_CHARACTER_WIDTH}, $self->{USER_CHARACTER_HEIGHT}) ; } else { my $layout = $self->{widget}->create_pango_layout('M') ; return $layout->get_pixel_size() ; } } #----------------------------------------------------------------------------- sub get_color { my ($self, $name) = @_; unless (exists $self->{ALLOCATED_COLORS}{$name}) { my $color ; if('ARRAY' eq ref $name) { $color = Gtk2::Gdk::Color->new( map {$_ * 257} @{$name}) ; } elsif(exists $self->{COLORS}{$name}) { if('ARRAY' eq ref $self->{COLORS}{$name}) { $color = Gtk2::Gdk::Color->new( map {$_ * 257} @{ $self->{COLORS}{$name}}) ; } else { $color = Gtk2::Gdk::Color->parse($self->{COLORS}{$name}); } } else { $color = Gtk2::Gdk::Color->parse($name); } $color = Gtk2::Gdk::Color->new( map {$_ * 257} (255, 0, 0)) unless defined $color ; $self->{widget}->get_colormap->alloc_color($color,TRUE,TRUE) ; $self->{ALLOCATED_COLORS}{$name} = $color ; } return($self->{ALLOCATED_COLORS}{$name}) ; } #----------------------------------------------------------------------------- =head1 DEPENDENCIES gnome libraries, gtk, gtk-perl, perl =head1 AUTHOR Khemir Nadim ibn Hamouda CPAN ID: NKH mailto:nadim@khemir.net =head1 LICENSE AND COPYRIGHT This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut #------------------------------------------------------------------------------------------------------ "GTK world domination!" ; App-Asciio-1.51.3/lib/App/Asciio/GTK/Asciio000755001750000144 012544473514 17500 5ustar00nadimusers000000000000App-Asciio-1.51.3/lib/App/Asciio/GTK/Asciio/Dialogs.pm000444001750000144 1317012544473514 21577 0ustar00nadimusers000000000000 package App::Asciio::GTK::Asciio ; $|++ ; use strict; use warnings; use Data::TreeDumper ; use Data::TreeDumper::Renderer::GTK ; #----------------------------------------------------------------------------- sub get_color_from_user { my ($self, $previous_color) = @_ ; my $color = Gtk2::Gdk::Color->new (@{$previous_color}); my $dialog = Gtk2::ColorSelectionDialog->new ("Changing color"); my $colorsel = $dialog->colorsel; $colorsel->set_previous_color ($color); $colorsel->set_current_color ($color); $colorsel->set_has_palette (TRUE); my $response = $dialog->run; if ($response eq 'ok') { $color = $colorsel->get_current_color; } $dialog->destroy; return [$color->red, $color->green , $color->blue] ; } #----------------------------------------------------------------------------- sub show_dump_window { my ($self, $data, $title, @dumper_setup) = @_ ; my $treedumper = Data::TreeDumper::Renderer::GTK->new ( data => $data, title => $title, dumper_setup => {@dumper_setup} ); $treedumper->modify_font(Gtk2::Pango::FontDescription->from_string ('monospace')); $treedumper->collapse_all; # some boilerplate to get the widget onto the screen... my $window = Gtk2::Window->new; my $scroller = Gtk2::ScrolledWindow->new; $scroller->add ($treedumper); $window->add ($scroller); $window->set_default_size(640, 1000) ; $window->show_all; } #----------------------------------------------------------------------------- sub display_message_modal { my ($self, $message) = @_ ; my $window = new Gtk2::Window() ; my $dialog = Gtk2::MessageDialog->new ( $window, 'destroy-with-parent' , 'info' , 'close' , $message , ) ; $dialog->signal_connect(response => sub { $dialog->destroy ; 1 }) ; $dialog->run() ; } #----------------------------------------------------------------------------- sub display_yes_no_cancel_dialog { my ($self, $title, $text) = @_ ; my $window = new Gtk2::Window() ; my $dialog = Gtk2::Dialog->new($title, $window, 'destroy-with-parent') ; $dialog->set_default_size (300, 150); $dialog->add_button ('gtk-yes' => 'yes'); $dialog->add_button ('gtk-no' => 'no'); $dialog->add_button ('gtk-cancel' => 'cancel'); my $lable = Gtk2::Label->new($text); $dialog->vbox->add ($lable); $lable->show; my $result = $dialog->run() ; $dialog->destroy ; return $result ; } #----------------------------------------------------------------------------- sub display_quit_dialog { my ($self, $title, $text) = @_ ; my $window = new Gtk2::Window() ; my $dialog = Gtk2::Dialog->new($title, $window, 'destroy-with-parent') ; $dialog->set_default_size (300, 150); add_button_with_icon ($dialog, 'Continue editing', 'gtk-cancel' => 'cancel'); add_button_with_icon ($dialog, 'Save and Quit', 'gtk-save' => 999); add_button_with_icon ($dialog, 'Quit and lose changes', 'gtk-ok' => 'ok'); my $lable = Gtk2::Label->new($text); $dialog->vbox->add ($lable); $lable->show; my $result = $dialog->run() ; $result = 'save_and_quit' if "$result" eq "999" ; $dialog->destroy ; return $result ; } sub add_button_with_icon { # code by Muppet my ($dialog, $text, $stock_id, $response_id) = @_; my $button = create_button ($text, $stock_id); $button->show; $dialog->add_action_widget ($button, $response_id); } # # Create a button with a stock icon but with non-stock text. # sub create_button { # code by Muppet my ($text, $stock_id) = @_; my $button = Gtk2::Button->new (); # # This setup is cribbed from gtk_button_construct_child() # in gtkbutton.c. It does not handle all the details like # left-to-right ordering and alignment and such, as in the # real button code. # my $image = Gtk2::Image->new_from_stock ($stock_id, 'button'); my $label = Gtk2::Label->new ($text); # accepts mnemonics $label->set_mnemonic_widget ($button); my $hbox = Gtk2::HBox->new (); $hbox->pack_start ($image, FALSE, FALSE, 0); $hbox->pack_start ($label, FALSE, FALSE, 0); $hbox->show_all (); $button->add ($hbox); return $button; } #----------------------------------------------------------------------------- sub display_edit_dialog { my ($self, $title, $text) = @_ ; $text ='' unless defined $text ; my $window = new Gtk2::Window() ; my $dialog = Gtk2::Dialog->new($title, $window, 'destroy-with-parent') ; $dialog->set_default_size (300, 150); $dialog->add_button ('gtk-ok' => 'ok'); my $textview = Gtk2::TextView->new; $textview->modify_font (Gtk2::Pango::FontDescription->from_string ('monospace 10')); my $buffer = $textview->get_buffer; $buffer->insert ($buffer->get_end_iter, $text); $dialog->vbox->add ($textview); $textview->show; # # Set up the dialog such that Ctrl+Return will activate the "ok" response. Muppet # #~ my $accel = Gtk2::AccelGroup->new; #~ $accel->connect #~ ( #~ Gtk2::Gdk->keyval_from_name ('Return'), ['control-mask'], [], #~ sub { $dialog->response ('ok'); } #~ ); #~ $dialog->add_accel_group ($accel); $dialog->run() ; my $new_text = $textview->get_buffer->get_text($buffer->get_start_iter, $buffer->get_end_iter, TRUE) ; $dialog->destroy ; return $new_text } #----------------------------------------------------------------------------- sub get_file_name { my ($self, $type) = @_ ; my $file_name = '' ; my $file_chooser = Gtk2::FileChooserDialog->new ( $type, undef, $type, 'gtk-cancel' => 'cancel', 'gtk-ok' => 'ok' ); $file_name = $file_chooser->get_filename if ('ok' eq $file_chooser->run) ; $file_chooser->destroy; return $file_name ; } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.51.3/lib/App/Asciio/GTK/Asciio/Menues.pm000444001750000144 630212544473514 21430 0ustar00nadimusers000000000000 package App::Asciio::GTK::Asciio ; $|++ ; use strict; use warnings; use Data::TreeDumper ; use Glib ':constants'; use Gtk2 -init; #------------------------------------------------------------------------------------------------------ sub display_popup_menu { my ($self, $event) = @_; my ($popup_x, $popup_y) = $event->coords() ; my @menu_items ; for my $element (@{$self->{ELEMENT_TYPES}}) { (my $name_with_underscore = $element->{NAME}) =~ s/_/__/g ; push @menu_items, [ "/$name_with_underscore", undef , insert_generator($self, $element, $popup_x, $popup_y), 0 , '', undef], } for my $menu_entry (@{$self->get_context_menu_entries($popup_x, $popup_y)}) { my($name, $sub, $data) = @{$menu_entry} ; (my $name_with_underscore = $name) =~ s/_/__/g ; push @menu_items, [ $name_with_underscore, undef , $self->menue_entry_wrapper($sub, $data), 0, '', undef], } push @menu_items, ( ['/File/open', undef , sub {$self->run_actions_by_name('Open') ;}, 0 , '', undef], ['/File/save', undef , sub {$self->run_actions_by_name('Save') ;}, 0 , '', undef], [ '/File/save as', undef , sub {$self->run_actions_by_name(['Save', 1]) ;}, 0 , '', undef], ) ; if($self->get_selected_elements(1) == 1) { push @menu_items, [ '/File/save stencil', undef , $self->menue_entry_wrapper(\&save_stencil), 0 , '', undef ] ; } my $item_factory = Gtk2::ItemFactory->new("Gtk2::Menu" ,"") ; $item_factory ->create_items($self->{widget}, @menu_items) ; my $menu = $item_factory->get_widget("") ; $menu->popup(undef, undef, undef, undef, $event->button, $event->time) ; } sub insert_generator { my ($self, $element, $x, $y) = @_ ; my ($character_width, $character_height) = $self->get_character_size() ; return sub { $self->add_new_element_of_type($element, $self->closest_character($x, $y)) ; $self->update_display(); } ; } sub menue_entry_wrapper { my ($self, $sub, $data) = @_ ; return sub { $sub->($self, $data) ; } ; } #------------------------------------------------------------------------------------------------------ my Readonly $SHORTCUTS = 0 ; my Readonly $CODE = 1 ; my Readonly $ARGUMENTS = 2 ; my Readonly $CONTEXT_MENUE_SUB = 3 ; my Readonly $CONTEXT_MENUE_ARGUMENTS = 4 ; my Readonly $NAME= 5 ; sub get_context_menu_entries { my ($self, $popup_x, $popup_y) = @_ ; my @context_menu_entries ; for my $context_menu_handler ( map {$self->{CURRENT_ACTIONS}{$_}} grep { 'ARRAY' eq ref $self->{CURRENT_ACTIONS}{$_} # not a sub actions definition && defined $self->{CURRENT_ACTIONS}{$_}[$CONTEXT_MENUE_SUB] } sort keys %{$self->{CURRENT_ACTIONS}} ) { #~ print "Adding context menue from action '$context_menu_handler->[$NAME]'.\n" ; if(defined $context_menu_handler->[$CONTEXT_MENUE_ARGUMENTS]) { push @context_menu_entries, $context_menu_handler->[$CONTEXT_MENUE_SUB]-> ( $self, $context_menu_handler->[$CONTEXT_MENUE_ARGUMENTS], $popup_x, $popup_y, ) ; } else { push @context_menu_entries, $context_menu_handler->[$CONTEXT_MENUE_SUB]->($self, $popup_x, $popup_y) ; } } return(\@context_menu_entries) ; } #------------------------------------------------------------------------------------------------------ 1 ; App-Asciio-1.51.3/lib/App/Asciio/GTK/Asciio/stripes000755001750000144 012544473514 21171 5ustar00nadimusers000000000000App-Asciio-1.51.3/lib/App/Asciio/GTK/Asciio/stripes/editable_box2.pm000444001750000144 1375312544473514 24420 0ustar00nadimusers000000000000 package App::Asciio::stripes::editable_box2 ; use base App::Asciio::stripes::single_stripe ; use strict; use warnings; use Glib ':constants'; use Gtk2 -init; use Glib qw(TRUE FALSE); #----------------------------------------------------------------------------- sub display_box_edit_dialog { my ($self, $title, $text) = @_ ; my $rows = $self->{BOX_TYPE} ; my $window = new Gtk2::Window() ; my $dialog = Gtk2::Dialog->new('Box attributes', $window, 'destroy-with-parent') ; $dialog->set_default_size (450, 305); $dialog->add_button ('gtk-ok' => 'ok'); #~ my $vbox = $dialog->vbox ; my $dialog_vbox = $dialog->vbox ; my $vbox = Gtk2::VBox->new (FALSE, 5); $dialog_vbox->pack_start ($vbox, TRUE, TRUE, 0); $vbox->pack_start (Gtk2::Label->new (""), FALSE, FALSE, 0); my $sw = Gtk2::ScrolledWindow->new; $sw->set_shadow_type ('etched-in'); $sw->set_policy ('automatic', 'automatic'); $vbox->pack_start ($sw, TRUE, TRUE, 0); # create model my $model = create_model ($rows); # create tree view my $treeview = Gtk2::TreeView->new_with_model ($model); $treeview->set_rules_hint (TRUE); $treeview->get_selection->set_mode ('single'); add_columns($treeview, $rows); $sw->add($treeview); # title my $titleview = Gtk2::TextView->new; $titleview->modify_font (Gtk2::Pango::FontDescription->from_string ('monospace 10')); my $title_buffer = $titleview->get_buffer ; $title_buffer->insert ($title_buffer->get_end_iter, $title); $vbox->add ($titleview); $titleview->show; # text my $textview = Gtk2::TextView->new; $textview->modify_font (Gtk2::Pango::FontDescription->from_string ('monospace 10')); my $text_buffer = $textview->get_buffer; $text_buffer->insert ($text_buffer->get_end_iter, $text); $vbox->add ($textview) ; $textview->show() ; # Focus and select, code by Tian $text_buffer->select_range($text_buffer->get_start_iter, $text_buffer->get_end_iter); $textview->grab_focus() ; # some buttons #~ my $hbox = Gtk2::HBox->new (TRUE, 4); #~ $vbox->pack_start ($hbox, FALSE, FALSE, 0); #~ my $button = Gtk2::Button->new ("Add item"); #~ $button->show() ; #~ $button->signal_connect (clicked => \&add_item, $model); #~ $hbox->pack_start ($button, TRUE, TRUE, 0); #~ $button = Gtk2::Button->new ("Remove item"); #~ $button->signal_connect (clicked => \&remove_item, $treeview); #~ $hbox->pack_start ($button, TRUE, TRUE, 0); #~ $hbox->show() ; $treeview->show() ; $vbox->show() ; $sw->show() ; $dialog->run() ; my $new_text = $textview->get_buffer->get_text($text_buffer->get_start_iter, $text_buffer->get_end_iter, TRUE) ; my $new_title = $titleview->get_buffer->get_text($title_buffer->get_start_iter, $title_buffer->get_end_iter, TRUE) ; $dialog->destroy ; return($new_text, $new_title) ; } #----------------------------------------------------------------------------- sub create_model { my ($rows) = @_ ; my $model = Gtk2::ListStore->new(qw/Glib::Boolean Glib::String Glib::String Glib::String Glib::String Glib::Boolean/); foreach my $row (@{$rows}) { my $iter = $model->append; my $column = 0 ; $model->set ($iter, map {$column++, $_} @{$row}) ; } return $model; } #----------------------------------------------------------------------------- sub add_columns { my ($treeview, $rows) = @_ ; my $model = $treeview->get_model; # column for fixed toggles my $renderer = Gtk2::CellRendererToggle->new; $renderer->signal_connect (toggled => \&display_toggled, [$model, $rows]) ; my $column = Gtk2::TreeViewColumn->new_with_attributes ( 'show', $renderer, active => 0 ) ; $column->set_sizing('fixed') ; $column->set_fixed_width(70) ; $treeview->append_column($column) ; # column for row titles my $row_renderer = Gtk2::CellRendererText->new; $row_renderer->set_data (column => 1); $treeview->insert_column_with_attributes(-1, '', $row_renderer, text => 1) ; #~ $column->set_sort_column_id (COLUMN_NUMBER); my $current_column = 2 ; for my $column_title('left', 'body', 'right') { my $renderer = Gtk2::CellRendererText->new; $renderer->signal_connect (edited => \&cell_edited, [$model, $rows]); $renderer->set_data (column => $current_column ); $treeview->insert_column_with_attributes ( -1, $column_title, $renderer, text => $current_column, editable => 5, ); $current_column++ ; } } #----------------------------------------------------------------------------- sub cell_edited { my ($cell, $path_string, $new_text, $model_and_rows) = @_; my ($model, $rows) = @{$model_and_rows} ; my $path = Gtk2::TreePath->new_from_string ($path_string); my $column = $cell->get_data ("column"); my $iter = $model->get_iter($path); my $row = ($path->get_indices)[0]; $rows->[$row][$column] = $new_text ; $model->set($iter, $column, $new_text); } #----------------------------------------------------------------------------- sub display_toggled { my ($cell, $path_string, $model_and_rows) = @_; my ($model, $rows) = @{$model_and_rows} ; my $column = $cell->get_data ('column'); my $path = Gtk2::TreePath->new ($path_string) ; my $iter = $model->get_iter ($path); my $display = $model->get($iter, 0); $rows->[$path_string][$column] = $display ^ 1 ; $model->set ($iter, 0, $display ^ 1); } #----------------------------------------------------------------------------- #~ sub add_item { #~ my ($button, $model) = @_; #~ push @articles, { #~ number => 0, #~ product => "Description here", #~ editable => TRUE, #~ }; #~ my $iter = $model->append; #~ $model->set ($iter, #~ COLUMN_NUMBER, $articles[-1]{number}, #~ COLUMN_PRODUCT, $articles[-1]{product}, #~ COLUMN_EDITABLE, $articles[-1]{editable}); #~ } #~ sub remove_item { #~ my ($widget, $treeview) = @_; #~ my $model = $treeview->get_model; #~ my $selection = $treeview->get_selection; #~ my $iter = $selection->get_selected; #~ if ($iter) { #~ my $path = $model->get_path ($iter); #~ my $i = ($path->get_indices)[0]; #~ $model->remove ($iter); #~ splice @articles, $i; #~ } #~ } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.51.3/lib/App/Asciio/GTK/Asciio/stripes/editable_arrow2.pm000444001750000144 566212544473514 24742 0ustar00nadimusers000000000000 package App::Asciio::stripes::editable_arrow2 ; use base App::Asciio::stripes::stripes ; use strict; use warnings; use Glib ':constants'; use Gtk2 -init; use Glib qw(TRUE FALSE); sub display_box_edit_dialog { my ($self) = @_ ; my $rows = $self->{ARROW_TYPE} ; my $window = new Gtk2::Window() ; my $dialog = Gtk2::Dialog->new('Arrow attributes', $window, 'destroy-with-parent') ; $dialog->set_default_size (220, 270); $dialog->add_button ('gtk-ok' => 'ok'); #~ my $vbox = $dialog->vbox ; my $dialog_vbox = $dialog->vbox ; my $vbox = Gtk2::VBox->new (FALSE, 5); $dialog_vbox->pack_start ($vbox, TRUE, TRUE, 0); $vbox->pack_start (Gtk2::Label->new (""), FALSE, FALSE, 0); my $sw = Gtk2::ScrolledWindow->new; $sw->set_shadow_type ('etched-in'); $sw->set_policy ('automatic', 'automatic'); $vbox->pack_start ($sw, TRUE, TRUE, 0); # create model my $model = create_model ($rows); # create tree view my $treeview = Gtk2::TreeView->new_with_model ($model); $treeview->set_rules_hint (TRUE); $treeview->get_selection->set_mode ('single'); add_columns($treeview, $rows); $sw->add($treeview); $treeview->show() ; $vbox->show() ; $sw->show() ; $dialog->run() ; $dialog->destroy ; } #----------------------------------------------------------------------------- sub create_model { my ($rows) = @_ ; my $model = Gtk2::ListStore->new(qw/Glib::String Glib::String Glib::String Glib::String Glib::Boolean/); foreach my $row (@{$rows}) { my $iter = $model->append; my $column = 0 ; $model->set ($iter, map {$column++, $_} @{$row}) ; } return $model; } #----------------------------------------------------------------------------- sub add_columns { my ($treeview, $rows) = @_ ; my $model = $treeview->get_model; # column for row titles my $row_renderer = Gtk2::CellRendererText->new; $row_renderer->set_data (column => 0); $treeview->insert_column_with_attributes ( -1, '', $row_renderer, text => 0, ) ; my $column = $treeview->get_column(0) ; $column->set_sizing('fixed') ; $column->set_fixed_width(80) ; my $current_column = 1 ; for my $column_title('start', 'body', 'end') { my $renderer = Gtk2::CellRendererText->new; $renderer->signal_connect (edited => \&cell_edited, [$model, $rows]); $renderer->set_data (column => $current_column ); $treeview->insert_column_with_attributes ( -1, $column_title, $renderer, text => $current_column, editable => 4, ); $current_column++ ; } } #----------------------------------------------------------------------------- sub cell_edited { my ($cell, $path_string, $new_text, $model_and_rows) = @_; my ($model, $rows) = @{$model_and_rows} ; my $path = Gtk2::TreePath->new_from_string ($path_string); my $column = $cell->get_data ("column"); my $iter = $model->get_iter($path); my $row = ($path->get_indices)[0]; $rows->[$row][$column] = $new_text ; $model->set($iter, $column, $new_text); } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.51.3/lib/App/Asciio/GTK/Asciio/stripes/wirl_arrow.pm000444001750000144 575312544473514 24065 0ustar00nadimusers000000000000 package App::Asciio::stripes::wirl_arrow ; use base App::Asciio::stripes::stripes ; use strict; use warnings; use Glib ':constants'; use Gtk2 -init; use Glib qw(TRUE FALSE); sub display_arrow_edit_dialog { my ($self) = @_ ; my $rows = $self->{ARROW_TYPE} ; my $window = new Gtk2::Window() ; my $dialog = Gtk2::Dialog->new('Arrow attributes', $window, 'destroy-with-parent') ; $dialog->set_default_size (450, 505); $dialog->add_button ('gtk-ok' => 'ok'); #~ my $vbox = $dialog->vbox ; my $dialog_vbox = $dialog->vbox ; my $vbox = Gtk2::VBox->new (FALSE, 5); $dialog_vbox->pack_start ($vbox, TRUE, TRUE, 0); $vbox->pack_start (Gtk2::Label->new (""), FALSE, FALSE, 0); my $sw = Gtk2::ScrolledWindow->new; $sw->set_shadow_type ('etched-in'); $sw->set_policy ('automatic', 'automatic'); $vbox->pack_start ($sw, TRUE, TRUE, 0); # create model my $model = create_model ($rows); # create tree view my $treeview = Gtk2::TreeView->new_with_model ($model); $treeview->set_rules_hint (TRUE); $treeview->get_selection->set_mode ('single'); add_columns($treeview, $rows); $sw->add($treeview); $treeview->show() ; $vbox->show() ; $sw->show() ; $dialog->run() ; $dialog->destroy ; } #----------------------------------------------------------------------------- sub create_model { my ($rows) = @_ ; my $model = Gtk2::ListStore->new(qw/Glib::String Glib::String Glib::String Glib::String Glib::String Glib::String Glib::Boolean/); foreach my $row (@{$rows}) { my $iter = $model->append; my $column = 0 ; $model->set ($iter, map {$column++, $_} @{$row}) ; } return $model; } #----------------------------------------------------------------------------- sub add_columns { my ($treeview, $rows) = @_ ; my $model = $treeview->get_model; # column for row titles my $row_renderer = Gtk2::CellRendererText->new; $row_renderer->set_data (column => 0); $treeview->insert_column_with_attributes ( -1, '', $row_renderer, text => 0, ) ; my $column = $treeview->get_column(0) ; $column->set_sizing('fixed') ; $column->set_fixed_width(120) ; my $current_column = 1 ; for my $column_title('start', 'body', 'connection', 'body_2', 'end') { my $renderer = Gtk2::CellRendererText->new; $renderer->signal_connect (edited => \&cell_edited, [$model, $rows]); $renderer->set_data (column => $current_column ); $treeview->insert_column_with_attributes ( -1, $column_title, $renderer, text => $current_column, editable => 6, ); $current_column++ ; } } #----------------------------------------------------------------------------- sub cell_edited { my ($cell, $path_string, $new_text, $model_and_rows) = @_; my ($model, $rows) = @{$model_and_rows} ; my $path = Gtk2::TreePath->new_from_string ($path_string); my $column = $cell->get_data ("column"); my $iter = $model->get_iter($path); my $row = ($path->get_indices)[0]; $rows->[$row][$column] = $new_text ; $model->set($iter, $column, $new_text); } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.51.3/lib/App/Asciio/Utils000755001750000144 012544473514 16744 5ustar00nadimusers000000000000App-Asciio-1.51.3/lib/App/Asciio/Utils/Presentation.pm000444001750000144 240412544473514 22112 0ustar00nadimusers000000000000 use strict; use warnings; #------------------------------------------------------------------------------------------------------ sub load_diagram { my ($x_offset, $y_offset, $file) = @_ ; return compose ( clear_all(), insert_diagram($x_offset, $y_offset, $file), ) ; } sub insert_diagram { my ($x_offset, $y_offset, $file) = @_ ; return sub { my ($self) = @_ ; $self->run_actions_by_name(['Insert', $x_offset, $y_offset, $file]) ; } ; } sub box { my ($x, $y, $title, $text, $select) = @_ ; return sub { my ($self) = @_ ; my $element = $self->add_new_element_named('stencils/asciio/box', $x, $y) ; $element->set_text($title, $text) ; $self->select_elements($select, $element) ; return $element ; } ; } sub clear_all { return sub { my ($self) = @_ ; $self->run_actions_by_name('Select all elements', 'Delete selected elements') ; } ; } sub compose { my (@elements) = @_ ; return sub { my ($self) = @_ ; for my $element (@elements) { $element->($self) ; } } ; } sub new_slide_single_box_at { my ($x_,$y, $text) = @_ ; return compose ( clear_all(), box($x_,$y, '', $text, 1), ) ; } #------------------------------------------------------------------------------------------------------ 1 ; App-Asciio-1.51.3/t000755001750000144 012544473514 13412 5ustar00nadimusers000000000000App-Asciio-1.51.3/t/003_multi_wirl_diagonal_connection.t000444001750000144 1127312544473514 22606 0ustar00nadimusers000000000000 use strict; use warnings; use lib qw(lib lib/stripes) ; use Test::More 'no_plan'; #----------------------------------------------------------------------------- use Readonly ; Readonly my $QUOTE_GLYPH => "'" ; Readonly my $DOT_GLYPH => '.' ; Readonly my $MINUS_GLYPH => '-' ; Readonly my $PIPE_GLYPH => '|' ; Readonly my $SLASH_GLYPH => '/' ; Readonly my $BACKSLAH_GLYPH => '\\' ; for my $multi_wirl ( # expected # 2 points #right + diagonal [$QUOTE_GLYPH, [4, 0, 'right'], [7, -3, '45']], [$QUOTE_GLYPH, [4, 0, 'right'], [1, -3, '315']], [$DOT_GLYPH, [4, 0, 'right'], [7, 3, '135']], [$DOT_GLYPH, [4, 0, 'right'], [1, 3, '225']], #down + diagonal [$QUOTE_GLYPH, [0, 4, 'down'], [3, 1, '45']], #5 [$QUOTE_GLYPH, [0, 4, 'down'], [-3, 1, '315']], [$DOT_GLYPH, [0, 4, 'down'], [3, 7, '135']], [$DOT_GLYPH, [0, 4, 'down'], [-3, 7, '225']], #45+ diagonal [$SLASH_GLYPH, [4, -4, '45'], [7, -7, '45']], #9 [$QUOTE_GLYPH, [4, -4, '45'], [1, -7, '315']], [$DOT_GLYPH, [4, -4, '45'], [7, -1, '135']], [$DOT_GLYPH, [4, -4, '45'], [1, -1, '225']], #225 + diagonal [$QUOTE_GLYPH, [-4, 4, '225'], [-1, 1, '45']], #13 [$QUOTE_GLYPH, [-4, 4, '225'], [-7, 1, '315']], [$DOT_GLYPH, [-4, 4, '225'], [-1, 7, '135']], [$SLASH_GLYPH, [-4, 4, '225'], [-7, 7, '225']], #left + diagonal [$QUOTE_GLYPH, [-4, 0, 'left'], [-1, -3, '45']], #17 [$QUOTE_GLYPH, [-4, 0, 'left'], [-7, -3, '315']], [$DOT_GLYPH, [-4, 0, 'left'], [-1, 3, '135']], [$DOT_GLYPH, [-4, 0, 'left'], [-7, 3, '225']], #up + diagonal [$QUOTE_GLYPH, [0, -4, 'up'], [3, -7, '45']], # 21 [$QUOTE_GLYPH, [0, -4, 'up'], [-3, -7, '315']], [$DOT_GLYPH, [0, -4, 'up'], [3, -1, '135']], [$DOT_GLYPH, [0, -4, 'up'], [-3, -1, '225']], #135 + diagonal [$QUOTE_GLYPH, [4, 4, '135'], [7, 1, '45']], # 25 [$QUOTE_GLYPH, [4, 4, '135'], [1, 1, '315']], [$BACKSLAH_GLYPH, [4, 4, '135'], [7, 7, '135']], [$DOT_GLYPH, [4, 4, '135'], [1, 7, '225']], #315 + diagonal [$QUOTE_GLYPH, [-4, -4, '315'], [-1, -7, '45']], # 29 [$BACKSLAH_GLYPH, [-4, -4, '315'], [-7, -7, '315']], [$DOT_GLYPH, [-4, -4, '315'], [-1, -1, '135']], [$DOT_GLYPH, [-4, -4, '315'], [-7, -1, '225']], # digonal + non diagonal #45 [$QUOTE_GLYPH, [4, -4, '45'], [4, -7, 'up']], #33 [$DOT_GLYPH, [4, -4, '45'], [7, -4, 'right']], [$DOT_GLYPH, [4, -4, '45'], [4, 1, 'down']], [$DOT_GLYPH, [4, -4, '45'], [1, -4, 'left']], #225 [$QUOTE_GLYPH, [-4, 4, '225'], [-4, 1, 'up']], #37 [$QUOTE_GLYPH, [-4, 4, '225'], [1, 4, 'right']], [$DOT_GLYPH, [-4, 4, '225'], [-4, 7, 'down']], [$QUOTE_GLYPH, [-4, 4, '225'], [-7, 4, 'left']], #135 [$QUOTE_GLYPH, [4, 4, '135'], [4, 1, 'up']], # 41 [$QUOTE_GLYPH, [4, 4, '135'], [7, 4, 'right']], [$DOT_GLYPH, [4, 4, '135'], [4, 7, 'down']], [$QUOTE_GLYPH, [4, 4, '135'], [1, 4, 'left']], #315 [$QUOTE_GLYPH, [-4, -4, '315'], [-4, -7, 'up']], # 45 [$DOT_GLYPH, [-4, -4, '315'], [-1, -4, 'right']], [$DOT_GLYPH, [-4, -4, '315'], [-4, -1, 'down']], [$DOT_GLYPH, [-4, -4, '315'], [-7, -4, 'left']], ) { my ($expected_connection_character, $point_1, $point_2) = @{$multi_wirl} ; my $origin = [10, 10] ; # offset the arrow as character with negative indexes don't ger rendered my ($text, $arrow_1_direction,$arrow_2_direction) = get_multi_wirl_connection_text($origin, $point_1, $point_2) ; #~ print $text ; my @buffer ; my $line_index = 0 ; for my $line (split "\n", $text) { $buffer[$line_index++] = [split '', $line] ; } my ($origin_x, $origin_y) = @{$origin} ; my ($point_1_x, $point_1_y) = @{$point_1} ; is($buffer[$point_1_y + $origin_y][$point_1_x + $origin_x], $expected_connection_character) or diag <[2], $point_2->[2] real directions: $arrow_1_direction,$arrow_2_direction $text EOD } #----------------------------------------------------------------------------- sub get_multi_wirl_connection_text { my ($origin, @points) = @_ ; use App::Asciio ; use App::Asciio::stripes::section_wirl_arrow; my $asciio = new App::Asciio() ; $asciio->set_character_size(8, 16) ; my $new_element = new App::Asciio::stripes::section_wirl_arrow ({ POINTS => [@points], DIRECTION => '', ALLOW_DIAGONAL_LINES => 1, EDITABLE => 1, RESIZABLE => 1, }) ; my ($character_width, $character_height) = $asciio->get_character_size() ; my ($origin_x, $origin_y) = @{$origin} ; @$new_element{'X', 'Y'} = ($origin_x, $origin_y) ; $asciio->add_elements($new_element) ; return $asciio->transform_elements_to_ascii_buffer(), $new_element->{ARROWS}[0]{DIRECTION}, $new_element->{ARROWS}[1]{DIRECTION}, ; } #----------------------------------------------------------------------------- App-Asciio-1.51.3/t/002_multi_wirl_connection.t000444001750000144 1151512544473514 20746 0ustar00nadimusers000000000000 use strict; use warnings; use lib qw(lib lib/stripes) ; use Test::More 'no_plan'; #----------------------------------------------------------------------------- use Readonly ; Readonly my $QUOTE_GLYPH => "'" ; Readonly my $DOT_GLYPH => '.' ; Readonly my $MINUS_GLYPH => '-' ; Readonly my $PIPE_GLYPH => '|' ; for my $multi_wirl ( # expected # 2 points [$MINUS_GLYPH, [-2, -2, 'upleft'], [-4, -2, 'left']], [$DOT_GLYPH, [0, -2, 'up'], [-4, -2, 'left']], [$QUOTE_GLYPH, [2, -2, 'upright'], [0, -4, 'upleft']], [$QUOTE_GLYPH, [5, 0, 'right'], [0, -2, 'upleft']], [$DOT_GLYPH, [5, -2, 'rightup'], [0, -2, 'left']], [$QUOTE_GLYPH, [5, 2, 'rightdown'], [0, 2, 'left']], [$MINUS_GLYPH, [-2, 5, 'downleft'], [-5, 5, 'left']], [$QUOTE_GLYPH, [0, 5, 'down'], [-5, 5, 'left']], [$DOT_GLYPH, [5, 2, 'downright'], [0, 4, 'downleft']], [$MINUS_GLYPH, [-2, 0, 'left'], [-5, 0, 'left']], [$DOT_GLYPH, [-2, -2, 'leftup'], [-5, -2, 'left']], [$QUOTE_GLYPH, [-2, 2, 'leftdown'], [-5, 2, 'left']], #-------------------------------------------------------------------------------------- [$QUOTE_GLYPH, [-2, -2, 'upleft'], [-2, -4, 'up']], [$PIPE_GLYPH, [0, -2, 'up'], [0, -4, 'up']], [$QUOTE_GLYPH, [2, -2, 'upright'], [2, -4, 'up']], [$QUOTE_GLYPH, [5, 0, 'right'], [5, -2, 'up']], [$PIPE_GLYPH, [5, -2, 'rightup'], [5, -4, 'up']], [$QUOTE_GLYPH, [5, 2, 'rightdown'], [10, 0, 'rightup']], [$QUOTE_GLYPH, [-2, 5, 'downleft'], [-2, 0, 'up']], [$QUOTE_GLYPH, [0, 5, 'down'], [2, 0, 'rightup']], [$QUOTE_GLYPH, [5, 2, 'downright'], [5, 0, 'up']], [$QUOTE_GLYPH, [-2, 0, 'left'], [-2, -2, 'up']], [$PIPE_GLYPH, [-2, -2, 'leftup'], [-2, -4, 'up']], [$QUOTE_GLYPH, [-2, 2, 'leftdown'], [-4, 0, 'leftup']], #-------------------------------------------------------------------------------------- [$QUOTE_GLYPH, [-2, -2, 'upleft'], [0, -4, 'upright']], [$DOT_GLYPH, [0, -2, 'up'], [4, 0, 'right']], [$MINUS_GLYPH, [2, -2, 'upright'], [4, -2, 'right']], [$MINUS_GLYPH, [5, 0, 'right'], [8, 0, 'right']], [$DOT_GLYPH, [5, -2, 'rightup'], [8, -2, 'right']], [$QUOTE_GLYPH, [5, 2, 'rightdown'], [10, 2, 'right']], [$DOT_GLYPH, [-2, 5, 'downleft'], [0, 7, 'downright']], [$QUOTE_GLYPH, [0, 5, 'down'], [5, 5, 'right']], [$MINUS_GLYPH, [5, 2, 'downright'], [8, 2, 'right']], [$QUOTE_GLYPH, [-2, 0, 'left'], [0, -2, 'upright']], [$DOT_GLYPH, [-2, -2, 'leftup'], [0, -2, 'right']], [$QUOTE_GLYPH, [-2, 2, 'leftdown'], [0, 2, 'right']], #-------------------------------------------------------------------------------------- [$DOT_GLYPH, [-2, -2, 'upleft'], [-2, 4, 'down']], [$DOT_GLYPH, [0, -2, 'up'], [4, 0, 'rightdown']], [$DOT_GLYPH, [2, -2, 'upright'], [2, 2, 'down']], [$DOT_GLYPH, [5, 0, 'right'], [5, 5, 'down']], [$DOT_GLYPH, [5, -2, 'rightup'], [8, 2, 'rightdown']], [$PIPE_GLYPH, [5, 2, 'rightdown'], [5, 5, 'down']], [$DOT_GLYPH, [-2, 5, 'downleft'], [-2, 7, 'down']], [$PIPE_GLYPH, [0, 5, 'down'], [0, 8, 'down']], [$DOT_GLYPH, [5, 2, 'downright'], [5, 5, 'down']], [$DOT_GLYPH, [-2, 0, 'left'], [-2, 5, 'down']], [$DOT_GLYPH, [-2, -2, 'leftup'], [-4, -4, 'leftdown']], [$PIPE_GLYPH, [-2, 2, 'leftdown'], [-2, 4, 'down']], #-------------------------------------------------------------------------------------- ) { my ($expected_connection_character, $point_1, $point_2) = @{$multi_wirl} ; my $origin = [10, 10] ; # offset the arrow as character with negative indexes don't ger rendered my $text = get_multi_wirl_connection_text($origin, $point_1, $point_2) ; #~ print $text ; my @buffer ; my $line_index = 0 ; for my $line (split "\n", $text) { $buffer[$line_index++] = [split '', $line] ; } my ($origin_x, $origin_y) = @{$origin} ; my ($point_1_x, $point_1_y) = @{$point_1} ; is($buffer[$point_1_y + $origin_y][$point_1_x + $origin_x], $expected_connection_character) or print "$point_1->[2], $point_2->[2]\n$text" ; } #----------------------------------------------------------------------------- sub get_multi_wirl_connection_text { my ($origin, @points) = @_ ; use App::Asciio ; use App::Asciio::stripes::section_wirl_arrow; my $asciio = new App::Asciio() ; $asciio->set_character_size(8, 16) ; my $new_element = new App::Asciio::stripes::section_wirl_arrow ({ POINTS => [@points], DIRECTION => '', ALLOW_DIAGONAL_LINES => 0, EDITABLE => 1, RESIZABLE => 1, }) ; my ($character_width, $character_height) = $asciio->get_character_size() ; my ($origin_x, $origin_y) = @{$origin} ; @$new_element{'X', 'Y'} = ($origin_x, $origin_y) ; $asciio->add_elements($new_element) ; return $asciio->transform_elements_to_ascii_buffer() ; } #----------------------------------------------------------------------------- App-Asciio-1.51.3/t/001_load.t000444001750000144 67612544473514 15224 0ustar00nadimusers000000000000 # test module loading use strict ; use warnings ; use Test::NoWarnings qw(warnings clear_warnings); use Test::Warn ; use Test::More qw(no_plan); use_ok( 'App::Asciio' ) or BAIL_OUT("Can't load module"); for my $warning (warnings()) { my $message = $warning->getMessage() ; chomp $message ; fail("No warnings. Found '$message'!") unless $message =~ /asked to lazy-load .* but that package is not registered/ ; } clear_warnings() ;App-Asciio-1.51.3/t/004_angled_arrows.t000444001750000144 3205512544473514 17173 0ustar00nadimusers000000000000 use strict; use warnings; use lib qw(lib lib/stripes) ; use Test::More 'no_plan'; use Data::TreeDumper ; use Hash::Slice 'slice' ; #----------------------------------------------------------------------------- use Readonly ; Readonly my $QUOTE_GLYPH => "'" ; Readonly my $DOT_GLYPH => '.' ; Readonly my $MINUS_GLYPH => '-' ; Readonly my $PIPE_GLYPH => '|' ; for my $angled_arrow_test ( # up, down, left, up, and origin are generic, angled arrow direction does not matter { ORIGIN => {X => 0, Y => 0}, END_X => 0, END_Y => 0, DIRECTION => 'up-right', RENDERING => <<'EOR', s EOR }, { ORIGIN => {X => 1, Y => 0}, END_X => -1, END_Y => 0, DIRECTION => 'up-right', RENDERING => <<'EOR', es EOR }, { ORIGIN => {X => 2, Y => 0}, END_X => -2, END_Y => 0, DIRECTION => 'up-right', RENDERING => <<'EOR', e1s EOR }, { ORIGIN => {X => 3, Y => 0}, END_X => -3, END_Y => 0, DIRECTION => 'up-right', RENDERING => <<'EOR', e11s EOR }, { ORIGIN => {X => 0, Y => 0}, END_X => 1, END_Y => 0, DIRECTION => 'up-right', RENDERING => <<'EOR', se EOR }, { ORIGIN => {X => 0, Y => 0}, END_X => 2, END_Y => 0, DIRECTION => 'up-right', RENDERING => <<'EOR', s1e EOR }, #---------------------------------------------------------- { ORIGIN => {X => 0, Y => 2}, END_X => 2, END_Y => -2, DIRECTION => 'up-right', RENDERING => <<'EOR', c 1 s EOR }, { ORIGIN => {X => 0, Y => 1}, END_X => 2, END_Y => -1, DIRECTION => 'up-right', RENDERING => <<'EOR', ce s EOR }, { ORIGIN => {X => 0, Y => 1}, END_X => 1, END_Y => -1, DIRECTION => 'up-right', RENDERING => <<'EOR', c s EOR }, #---------------------------------------------------------- { ORIGIN => {X => 7, Y => 4}, END_X => -7, END_Y => -4, DIRECTION => 'up-left', RENDERING => <<'EOR', e22c 1 1 1 s EOR }, { ORIGIN => {X => 6, Y => 4}, END_X => -6, END_Y => -4, DIRECTION => 'up-left', RENDERING => <<'EOR', e2c 1 1 1 s EOR }, { ORIGIN => {X => 5, Y => 4}, END_X => -5, END_Y => -4, DIRECTION => 'up-left', RENDERING => <<'EOR', ec 1 1 1 s EOR }, { ORIGIN => {X => 4, Y => 4}, END_X => -4, END_Y => -4, DIRECTION => 'up-left', RENDERING => <<'EOR', c 1 1 1 s EOR }, { ORIGIN => {X => 3, Y => 4}, END_X => -3, END_Y => -4, DIRECTION => 'up-left', RENDERING => <<'EOR', c 1 1 C s EOR }, { ORIGIN => {X => 2, Y => 4}, END_X => -2, END_Y => -4, DIRECTION => 'up-left', RENDERING => <<'EOR', c 1 C | s EOR }, { ORIGIN => {X => 1, Y => 4}, END_X => -1, END_Y => -4, DIRECTION => 'up-left', RENDERING => <<'EOR', c C | | s EOR }, { ORIGIN => {X => 0, Y => 4}, END_X => 0, END_Y => -4, DIRECTION => 'up-left', RENDERING => <<'EOR', e 1 1 1 s EOR }, #---------------------------------------------------------- { ORIGIN => {X => 7, Y => 4}, END_X => -7, END_Y => -4, DIRECTION => 'left-up', RENDERING => <<'EOR', e 1 1 1 c22s EOR }, { ORIGIN => {X => 6, Y => 4}, END_X => -6, END_Y => -4, DIRECTION => 'left-up', RENDERING => <<'EOR', e 1 1 1 c2s EOR }, { ORIGIN => {X => 5, Y => 4}, END_X => -5, END_Y => -4, DIRECTION => 'left-up', RENDERING => <<'EOR', e 1 1 1 cs EOR }, { ORIGIN => {X => 4, Y => 4}, END_X => -4, END_Y => -4, DIRECTION => 'left-up', RENDERING => <<'EOR', e 1 1 1 c EOR }, { ORIGIN => {X => 3, Y => 4}, END_X => -3, END_Y => -4, DIRECTION => 'left-up', RENDERING => <<'EOR', e C 1 1 c EOR }, { ORIGIN => {X => 2, Y => 4}, END_X => -2, END_Y => -4, DIRECTION => 'left-up', RENDERING => <<'EOR', e | C 1 c EOR }, { ORIGIN => {X => 1, Y => 4}, END_X => -1, END_Y => -4, DIRECTION => 'left-up', RENDERING => <<'EOR', e | | C c EOR }, { # dranw as 'up' ORIGIN => {X => 0, Y => 4}, END_X => 0, END_Y => -4, DIRECTION => 'left-up', RENDERING => <<'EOR', e 1 1 1 s EOR }, #-------------------------------------------------------------------------------------- { ORIGIN => {X => 0, Y => 4}, END_X => 7, END_Y => -4, DIRECTION => 'up-right', RENDERING => <<'EOR', c22e 1 1 1 s EOR }, { ORIGIN => {X => 0, Y => 4}, END_X => 6, END_Y => -4, DIRECTION => 'up-right', RENDERING => <<'EOR', c2e 1 1 1 s EOR }, { ORIGIN => {X => 0, Y => 4}, END_X => 5, END_Y => -4, DIRECTION => 'up-right', RENDERING => <<'EOR', ce 1 1 1 s EOR }, { ORIGIN => {X => 0, Y => 4}, END_X => 4, END_Y => -4, DIRECTION => 'up-right', RENDERING => <<'EOR', c 1 1 1 s EOR }, { ORIGIN => {X => 0, Y => 4}, END_X => 3, END_Y => -4, DIRECTION => 'up-right', RENDERING => <<'EOR', c 1 1 C s EOR }, { ORIGIN => {X => 0, Y => 4}, END_X => 2, END_Y => -4, DIRECTION => 'up-right', RENDERING => <<'EOR', c 1 C | s EOR }, { ORIGIN => {X => 0, Y => 4}, END_X => 1, END_Y => -4, DIRECTION => 'up-right', RENDERING => <<'EOR', c C | | s EOR }, { # drawn as 'up' ORIGIN => {X => 0, Y => 4}, END_X => 0, END_Y => -4, DIRECTION => 'up-right', RENDERING => <<'EOR', e 1 1 1 s EOR }, #-------------------------------------------------------------------------------------- { ORIGIN => {X => 0, Y => 4}, END_X => 7, END_Y => -4, DIRECTION => 'right-up', RENDERING => <<'EOR', e 1 1 1 s22c EOR }, { ORIGIN => {X => 0, Y => 4}, END_X => 6, END_Y => -4, DIRECTION => 'right-up', RENDERING => <<'EOR', e 1 1 1 s2c EOR }, { ORIGIN => {X => 0, Y => 4}, END_X => 5, END_Y => -4, DIRECTION => 'right-up', RENDERING => <<'EOR', e 1 1 1 sc EOR }, { ORIGIN => {X => 0, Y => 4}, END_X => 4, END_Y => -4, DIRECTION => 'right-up', RENDERING => <<'EOR', e 1 1 1 c EOR }, { ORIGIN => {X => 0, Y => 4}, END_X => 3, END_Y => -4, DIRECTION => 'right-up', RENDERING => <<'EOR', e C 1 1 c EOR }, { ORIGIN => {X => 0, Y => 4}, END_X => 2, END_Y => -4, DIRECTION => 'right-up', RENDERING => <<'EOR', e | C 1 c EOR }, { ORIGIN => {X => 0, Y => 4}, END_X => 1, END_Y => -4, DIRECTION => 'right-up', RENDERING => <<'EOR', e | | C c EOR }, { # drawn as 'up' ORIGIN => {X => 0, Y => 4}, END_X => 0, END_Y => -4, DIRECTION => 'right-up', RENDERING => <<'EOR', e 1 1 1 s EOR }, #-------------------------------------------------------------------------------------- { ORIGIN => {X => 7, Y => 0}, END_X => -7, END_Y => 4, DIRECTION => 'down-left', RENDERING => <<'EOR', s 1 1 1 e22c EOR }, { ORIGIN => {X => 6, Y => 0}, END_X => -6, END_Y => 4, DIRECTION => 'down-left', RENDERING => <<'EOR', s 1 1 1 e2c EOR }, { ORIGIN => {X => 5, Y => 0}, END_X => -5, END_Y => 4, DIRECTION => 'down-left', RENDERING => <<'EOR', s 1 1 1 ec EOR }, { ORIGIN => {X => 4, Y => 0}, END_X => -4, END_Y => 4, DIRECTION => 'down-left', RENDERING => <<'EOR', s 1 1 1 c EOR }, { ORIGIN => {X => 3, Y => 0}, END_X => -3, END_Y => 4, DIRECTION => 'down-left', RENDERING => <<'EOR', s C 1 1 c EOR }, { ORIGIN => {X => 2, Y => 0}, END_X => -2, END_Y => 4, DIRECTION => 'down-left', RENDERING => <<'EOR', s | C 1 c EOR }, { ORIGIN => {X => 1, Y => 0}, END_X => -1, END_Y => 4, DIRECTION => 'down-left', RENDERING => <<'EOR', s | | C c EOR }, { # drawn as 'down' ORIGIN => {X => 0, Y => 0}, END_X => 0, END_Y => 4, DIRECTION => 'down-left', RENDERING => <<'EOR', s 1 1 1 e EOR }, #-------------------------------------------------------------------------------------- { ORIGIN => {X => 7, Y => 0}, END_X => -7, END_Y => 4, DIRECTION => 'left-down', RENDERING => <<'EOR', c22s 1 1 1 e EOR }, { ORIGIN => {X => 6, Y => 0}, END_X => -6, END_Y => 4, DIRECTION => 'left-down', RENDERING => <<'EOR', c2s 1 1 1 e EOR }, { ORIGIN => {X => 5, Y => 0}, END_X => -5, END_Y => 4, DIRECTION => 'left-down', RENDERING => <<'EOR', cs 1 1 1 e EOR }, { ORIGIN => {X => 4, Y => 0}, END_X => -4, END_Y => 4, DIRECTION => 'left-down', RENDERING => <<'EOR', c 1 1 1 e EOR }, { ORIGIN => {X => 3, Y => 0}, END_X => -3, END_Y => 4, DIRECTION => 'left-down', RENDERING => <<'EOR', c 1 1 C e EOR }, { ORIGIN => {X => 2, Y => 0}, END_X => -2, END_Y => 4, DIRECTION => 'left-down', RENDERING => <<'EOR', c 1 C | e EOR }, { ORIGIN => {X => 1, Y => 0}, END_X => -1, END_Y => 4, DIRECTION => 'left-down', RENDERING => <<'EOR', c C | | e EOR }, { # drawn as 'down' ORIGIN => {X => 0, Y => 0}, END_X => 0, END_Y => 4, DIRECTION => 'left-down', RENDERING => <<'EOR', s 1 1 1 e EOR }, #-------------------------------------------------------------------------------------- ) { ORIGIN => {X => 0, Y => 0}, END_X => 7, END_Y => 4, DIRECTION => 'down-right', RENDERING => <<'EOR', s 1 1 1 c22e EOR }, { ORIGIN => {X => 0, Y => 0}, END_X => 6, END_Y => 4, DIRECTION => 'down-right', RENDERING => <<'EOR', s 1 1 1 c2e EOR }, { ORIGIN => {X => 0, Y => 0}, END_X => 5, END_Y => 4, DIRECTION => 'down-right', RENDERING => <<'EOR', s 1 1 1 ce EOR }, { ORIGIN => {X => 0, Y => 0}, END_X => 4, END_Y => 4, DIRECTION => 'down-right', RENDERING => <<'EOR', s 1 1 1 c EOR }, { ORIGIN => {X => 0, Y => 0}, END_X => 3, END_Y => 4, DIRECTION => 'down-right', RENDERING => <<'EOR', s C 1 1 c EOR }, { ORIGIN => {X => 0, Y => 0}, END_X => 2, END_Y => 4, DIRECTION => 'down-right', RENDERING => <<'EOR', s | C 1 c EOR }, { ORIGIN => {X => 0, Y => 0}, END_X => 1, END_Y => 4, DIRECTION => 'down-right', RENDERING => <<'EOR', s | | C c EOR }, { # drawn as 'down' ORIGIN => {X => 0, Y => 0}, END_X => 0, END_Y => 4, DIRECTION => 'down-right', RENDERING => <<'EOR', s 1 1 1 e EOR }, #-------------------------------------------------------------------------------------- { ORIGIN => {X => 0, Y => 0}, END_X => 7, END_Y => 4, DIRECTION => 'right-down', RENDERING => <<'EOR', s22c 1 1 1 e EOR }, { ORIGIN => {X => 0, Y => 0}, END_X => 6, END_Y => 4, DIRECTION => 'right-down', RENDERING => <<'EOR', s2c 1 1 1 e EOR }, { ORIGIN => {X => 0, Y => 0}, END_X => 5, END_Y => 4, DIRECTION => 'right-down', RENDERING => <<'EOR', sc 1 1 1 e EOR }, { ORIGIN => {X => 0, Y => 0}, END_X => 4, END_Y => 4, DIRECTION => 'right-down', RENDERING => <<'EOR', c 1 1 1 e EOR }, { ORIGIN => {X => 0, Y => 0}, END_X => 3, END_Y => 4, DIRECTION => 'right-down', RENDERING => <<'EOR', c 1 1 C e EOR }, { ORIGIN => {X => 0, Y => 0}, END_X => 2, END_Y => 4, DIRECTION => 'right-down', RENDERING => <<'EOR', c 1 C | e EOR }, { ORIGIN => {X => 0, Y => 0}, END_X => 1, END_Y => 4, DIRECTION => 'right-down', RENDERING => <<'EOR', c C | | e EOR }, { # drawn as 'down' ORIGIN => {X => 0, Y => 0}, END_X => 0, END_Y => 4, DIRECTION => 'right-down', RENDERING => <<'EOR', s 1 1 1 e EOR }, ) { my ($text, $asciio, $new_element) = get_angled_arrow_text($angled_arrow_test) ; is ( "\n$text", "\n$angled_arrow_test->{RENDERING}", DumpTree ( scalar(slice($angled_arrow_test, qw[END_X END_Y DIRECTION])), '', DISPLAY_ADDRESS => 0, USE_ASCII => 0 , ) ) or do { diag DumpTree ( [split /\n/, $text], 'got:', QUOTE_VALUES => 1, DISPLAY_ADDRESS => 0, USE_ASCII => 0 , ) ; diag DumpTree ( [split /\n/, $angled_arrow_test->{RENDERING}], 'expected:', QUOTE_VALUES => 1, DISPLAY_ADDRESS => 0, USE_ASCII => 0 , ) ; #~ diag DumpTree #~ ( #~ $asciio, #~ 'asciio:', #~ QUOTE_VALUES => 1, #~ DISPLAY_ADDRESS => 1, #~ USE_ASCII => 0 , #~ ) ; last ; } } #----------------------------------------------------------------------------- sub get_angled_arrow_text { my ($angled_arrow_definition) = @_ ; use App::Asciio ; use App::Asciio::stripes::angled_arrow; my $asciio = new App::Asciio() ; $asciio->set_character_size(8, 16) ; my $new_element = new App::Asciio::stripes::angled_arrow ({ GLYPHS => #name: => [$start, $body, $connection, $body_2, $end] { 'origin' => ['s', '1', 'c', '2', 'e', '|', 'C'], 'up'=> ['s', '1', 'c', '2', 'e', '|', 'C'], 'down' => ['s', '1', 'c', '2', 'e', '|', 'C'], 'left' => ['s', '1', 'c', '2', 'e', '|', 'C'], 'upleft' => ['s', '1', 'c', '2', 'e', '|', 'C'], 'leftup' => ['s', '1', 'c', '2', 'e', '|', 'C'], 'downleft' => ['s', '1', 'c', '2', 'e', '|', 'C'], 'leftdown' => ['s', '1', 'c', '2', 'e', '|', 'C'], 'right' => ['s', '1', 'c', '2', 'e', '|', 'C'], 'upright' => ['s', '1', 'c', '2', 'e', '|', 'C'], 'rightup' => ['s', '1', 'c', '2', 'e', '|', 'C'], 'downright' => ['s', '1', 'c', '2', 'e', '|', 'C'], 'rightdown' => ['s', '1', 'c', '2', 'e', '|', 'C'], }, %{$angled_arrow_definition}, RESIZABLE => 1, }) ; @$new_element{'X', 'Y'} = ($angled_arrow_definition->{ORIGIN}{X}, $angled_arrow_definition->{ORIGIN}{Y}) ; $asciio->add_elements($new_element) ; return($asciio->transform_elements_to_ascii_buffer(), $asciio, $new_element) ; } App-Asciio-1.51.3/documentation000755001750000144 012544473514 16020 5ustar00nadimusers000000000000App-Asciio-1.51.3/documentation/presentation.pl000444001750000144 71612544473514 21211 0ustar00nadimusers000000000000use strict ; use warnings ; use App::Asciio::Utils::Presentation ; [ new_slide_single_box_at(13, 10, < <) EOT ] ; App-Asciio-1.51.3/documentation/scripting000755001750000144 012544473514 20022 5ustar00nadimusers000000000000App-Asciio-1.51.3/documentation/scripting/three_boxes.pl000444001750000144 143212544473514 23023 0ustar00nadimusers000000000000 use strict; use warnings; use lib qw(lib lib/stripes) ; use App::Asciio; use App::Asciio::stripes::editable_box2 ; #----------------------------------------------------------------------------- my $asciio = new App::Asciio() ; #----------------------------------------------------------------------------- my ($current_x, $current_y) = (0, 0) ; for my $element_text (qw(box_1 box_2 box_3)) { my $new_element = new App::Asciio::stripes::editable_box2 ({ TEXT_ONLY => $element_text, TITLE => '', EDITABLE => 1, RESIZABLE => 1, }) ; $asciio->add_element_at($new_element, $current_x, $current_y) ; $current_x += $asciio->{COPY_OFFSET_X} ; $current_y += $asciio->{COPY_OFFSET_Y} ; } print $asciio->transform_elements_to_ascii_buffer() ; App-Asciio-1.51.3/documentation/scripting/objects.pl000444001750000144 304212544473514 22144 0ustar00nadimusers000000000000 use strict; use warnings; use lib qw(lib lib/stripes) ; use Data::TreeDumper ; use App::Asciio ; use App::Asciio::stripes::editable_box2 ; use App::Asciio::stripes::process_box ; use App::Asciio::stripes::single_stripe ; #----------------------------------------------------------------------------- my $asciio = new App::Asciio() ; #----------------------------------------------------------------------------- my ($current_x, $current_y) = (0, 0) ; my $new_box = new App::Asciio::stripes::editable_box2 ({ TEXT_ONLY => 'box', TITLE => '', EDITABLE => 1, RESIZABLE => 1, }) ; $asciio->add_element_at($new_box, 0, 0) ; my $new_process = new App::Asciio::stripes::process_box ({ TEXT_ONLY => 'process', EDITABLE => 1, RESIZABLE => 1, }) ; $asciio->add_element_at($new_process, 25, 0) ; my $new_stripe = new App::Asciio::stripes::single_stripe ({ TEXT => 'stripe', }) ; $asciio->add_element_at($new_stripe, 50, 0) ; print $asciio->transform_elements_to_ascii_buffer() ; $new_box->set_text('title', "line 1\nline 2") ; $new_process->set_text("line 1\nline2\nline3") ; $new_stripe->set_text( "line 1\nline2") ; print $asciio->transform_elements_to_ascii_buffer() ; for ($new_box, $new_process, $new_stripe) { print "\n-------------------------------------------------------\n\n" ; print 'type: ', ref($_), "\n" ; print 'size:', join(",", $_->get_size()) , "\n" ; print DumpTree([$_->get_connection_points()], 'connection points:') , "\n" ; print 'text : ', join("\n", $_->get_text()) , "\n" ; } App-Asciio-1.51.3/documentation/scripting/multi_wirl.pl000444001750000144 125012544473514 22701 0ustar00nadimusers000000000000 use strict; use warnings; use lib qw(lib lib/stripes) ; use App::Asciio ; use App::Asciio::stripes::section_wirl_arrow; #----------------------------------------------------------------------------- my $asciio = new App::Asciio() ; #----------------------------------------------------------------------------- my $new_element = new App::Asciio::stripes::section_wirl_arrow ({ POINTS => [[5, 5, 'downright'], [10, 7, 'downright'], [7, 14, 'downleft'], ], DIRECTION => '', ALLOW_DIAGONAL_LINES => 0, EDITABLE => 1, RESIZABLE => 1, }) ; $asciio->add_element_at($new_element, 5, 5) ; print $asciio->transform_elements_to_ascii_buffer() ; App-Asciio-1.51.3/documentation/scripting/if_objects.pl000444001750000144 164512544473514 22631 0ustar00nadimusers000000000000 use strict; use warnings; use lib qw(lib lib/stripes) ; use Data::TreeDumper ; use App::Asciio ; use App::Asciio::stripes::if_box ; #----------------------------------------------------------------------------- my $asciio = new App::Asciio() ; #----------------------------------------------------------------------------- my @text = ( 'a == 1235', 'b < 0', 'b > 125', 'very long', '&& $x >= $y_123', 'c eq 35', ' $a ~= /^$/', ) ; my $box_index = 0 ; my $next_line = 0 ; for (1 .. 7) { my $text = '' ; $text .= $text[rand(@text)] . "\n" for (1 .. $box_index) ; my $if_box = new App::Asciio::stripes::if_box ({ TEXT_ONLY => $text, EDITABLE => 1, RESIZABLE => 1, }) ; @$if_box{'X', 'Y'} = (0, $next_line) ; $asciio->add_elements($if_box) ; my ($w, $h) = $if_box->get_size() ; $next_line += $h + 1 ; $box_index++ ; } print $asciio->transform_elements_to_ascii_buffer() ; App-Asciio-1.51.3/documentation/scripting/manual_connect.pl000444001750000144 270012544473514 23501 0ustar00nadimusers000000000000 use strict; use warnings; use lib qw(documentation/scripting/lib) ; use App::Asciio ; use scripting_lib ; #----------------------------------------------------------------------------- my $asciio = new App::Asciio() ; my ($command_line_switch_parse_ok, $command_line_parse_message, $asciio_config) = $asciio->ParseSwitches([@ARGV], 0) ; die "Error: '$command_line_parse_message'!" unless $command_line_switch_parse_ok ; $asciio->setup($asciio_config->{SETUP_INI_FILE}, $asciio_config->{SETUP_PATH}) ; #----------------------------------------------------------------------------- my $box1 = new_box(TEXT_ONLY =>'box1') ; $asciio->add_element_at($box1, 0, 2) ; my $box2 = new_box(TEXT_ONLY =>'box2') ; $asciio->add_element_at($box2, 20, 10) ; my $box3 = new_box(TEXT_ONLY =>'box3') ; $asciio->add_element_at($box3, 40, 5) ; my $arrow = new_wirl_arrow () ; $asciio->add_element_at($arrow, 0,0) ; my $start_connection = move_named_connector($arrow, 'startsection_0', $box1, 'bottom_center'); my $end_connection = move_named_connector($arrow, 'endsection_0', $box2, 'bottom_center') ; die "missing connection!" unless defined $start_connection && defined $end_connection ; $asciio->add_connections($start_connection, $end_connection) ; get_canonizer()->([$start_connection, $end_connection]) ; print $asciio->transform_elements_to_ascii_buffer() ; #----------------------------------------------------------------------------------------------------------- App-Asciio-1.51.3/documentation/scripting/connected_boxes.pl000444001750000144 206312544473514 23657 0ustar00nadimusers000000000000 use strict; use warnings; use lib qw(lib/stripes documentation/scripting/lib) ; use App::Asciio ; use scripting_lib ; #----------------------------------------------------------------------------- my $asciio = new App::Asciio() ; my ($command_line_switch_parse_ok, $command_line_parse_message, $asciio_config) = $asciio->ParseSwitches([@ARGV], 0) ; die "Error: '$command_line_parse_message'!" unless $command_line_switch_parse_ok ; $asciio->setup($asciio_config->{SETUP_INI_FILE}, $asciio_config->{SETUP_PATH}) ; #----------------------------------------------------------------------------- my $box1 = new_box(TEXT_ONLY =>'box1') ; $asciio->add_element_at($box1, 0, 2) ; my $box2 = new_box(TEXT_ONLY =>'box2') ; $asciio->add_element_at($box2, 20, 10) ; my $box3 = new_box(TEXT_ONLY =>'box3') ; $asciio->add_element_at($box3, 40, 5) ; add_connection($asciio, $box1, $box2, 'down') ; add_connection($asciio, $box2, $box3, ) ; add_connection($asciio, $box3, $box1, 'up') ; optimize_connections($asciio) ; print $asciio->transform_elements_to_ascii_buffer() ; App-Asciio-1.51.3/documentation/scripting/lib000755001750000144 012544473514 20570 5ustar00nadimusers000000000000App-Asciio-1.51.3/documentation/scripting/lib/scripting_lib.pm000444001750000144 1030012544473514 24125 0ustar00nadimusers000000000000 use strict; use warnings; use lib qw(lib lib/stripes) ; #-------------------------------------------------------------------------------------------- sub new_box { my (@arguments_to_constructor) = @_ ; use App::Asciio::stripes::editable_box2 ; my $box = new App::Asciio::stripes::editable_box2 ({ TEXT_ONLY => 'box', TITLE => '', EDITABLE => 1, RESIZABLE => 1, @arguments_to_constructor, }) ; return($box) ; } #----------------------------------------------------------------------------------------------------------- sub new_wirl_arrow { my (@arguments) = @_ ; use App::Asciio::stripes::section_wirl_arrow ; my $arrow = new App::Asciio::stripes::section_wirl_arrow ({ POINTS => [[5, 5, 'downright']], DIRECTION => '', ALLOW_DIAGONAL_LINES => 0, EDITABLE => 1, RESIZABLE => 1, @arguments, }) ; } #-------------------------------------------------------------------------------------------- sub add_connection { my ($self, $source_element, $destination_element, $hint, @arguments_to_constructor) = @_ ; $hint ||= 'right-down' ; my @destination_connections = grep {$_->{NAME} ne 'resize'} $destination_element->get_connection_points() ; my $destination_connection = $destination_connections[0] ; my @source_connections = grep {$_->{NAME} ne 'resize'} $source_element->get_connection_points() ; my $source_connection = $source_connections[0] ; my $new_element = new App::Asciio::stripes::section_wirl_arrow ({ POINTS => [ [ ($destination_element->{X} + $destination_connection->{X}) - ($source_element->{X} + $source_connection->{X}) , ($destination_element->{Y} + $destination_connection->{Y}) - ($source_element->{Y} + $source_connection->{Y}) , $hint, ] ], DIRECTION => $hint, ALLOW_DIAGONAL_LINES => 0, EDITABLE => 1, RESIZABLE => 1, @arguments_to_constructor, }) ; # let check_connection do the job of optimizing @$new_element{'X', 'Y'} = ($source_element->{X} + $source_connection->{X}, $source_element->{Y} + $source_connection->{Y}) ; $self->add_elements($new_element) ; } #-------------------------------------------------------------------------------------------- sub move_named_connector { my ($connected, $connector_name, $connectee, $connection_name) = @_ ; do { die "Invalid argument to 'move_named_connector'!\n" unless defined $_} for (@_) ; die "Invalid number of arguments to 'move_named_connector'!\n" unless @_ == 4 ; my $connector = $connected->get_named_connection($connector_name) ; my $connection = $connectee->get_named_connection($connection_name) ; if(defined $connector && defined $connection) { my $connector_x = $connected->{X} + $connector->{X} ; my $connector_y = $connected->{Y} + $connector->{Y} ; my $connection_x = $connectee->{X} + $connection->{X} ; my $connection_y = $connectee->{Y} + $connection->{Y} ; my $connector_x_offset = $connection_x - $connector_x ; my $connector_y_offset = $connection_y - $connector_y ; my ($x_offset, $y_offset, $width, $height, $new_connector) = $connected->move_connector ( $connector_name, $connector_x_offset, $connector_y_offset ) ; $connected->{X} += $x_offset ; $connected->{Y} += $y_offset ; return { CONNECTED => $connected, CONNECTOR =>$new_connector, CONNECTEE => $connectee, CONNECTION => $connection, } ; } else { return ; } } #----------------------------------------------------------------------------------------------------------- sub optimize_connections { my ($self) = @_; $self->call_hook('CANONIZE_CONNECTIONS', $self->{CONNECTIONS}) ; } #-------------------------------------------------------------------------------------------- sub get_canonizer { my $context = new Eval::Context() ; $context->eval ( REMOVE_PACKAGE_AFTER_EVAL => 0, # VERY IMPORTANT as we return code references that will cease to exist otherwise PRE_CODE => <<'EOC' , use strict; use warnings; sub register_hooks { return \&canonize_connections ; } EOC CODE_FROM_FILE => 'setup/hooks/canonize_connections.pl' , ) ; } #-------------------------------------------------------------------------------------------- 1 ; App-Asciio-1.51.3/documentation/text000755001750000144 012544473514 17004 5ustar00nadimusers000000000000App-Asciio-1.51.3/documentation/text/permissions.txt000444001750000144 50512544473514 22235 0ustar00nadimusers000000000000 421 421 421 \ | / \ | / v v v drwxrwxrwx ^| || || | / '-''-''-' / ^ ^ ^ file type \ \ \ indicator \ \ \ user \ \ group \ other App-Asciio-1.51.3/documentation/text/depend_and_build.txt000444001750000144 366312544473514 23152 0ustar00nadimusers000000000000 .---------------------------. | PBS::CreateDependencyTree | '---------------------------' | | <-----------------------------------------------depend only------------------------------------------------> | | .-----------. .-------------------. .-------------------------. .---------------------. .---------------------------. '-->| Depender |--->| C_SourceDepender |--->| GenerateDependencyFile |--->| $PreprocessorDepend |-->| Devel::Depend::Cl::Depend | '-----------'| '-------------------' '-------------------------'| '---------------------' '---------------------------' | | | | | | <-----------------------------------depend and build simulteanously----------------------------------------> | | | .--------------------------. | '->| C_DependAndBuildDepender | | '--------------------------' | ^ | | | | | | v | .-------------------------------. | .----------------------. .---------------------------------. | Generate $PreprocessorDepend2 | '---| $PreprocessorDepend2 |--->| Devel::Depend::Cl::RunAndParse | '-------------------------------' '----------------------' '---------------------------------' App-Asciio-1.51.3/script000755001750000144 012544473514 14453 5ustar00nadimusers000000000000App-Asciio-1.51.3/script/A000555001750000144 4512544473514 14655 0ustar00nadimusers000000000000./Build perl -Mblib script/asciio $@ App-Asciio-1.51.3/script/asciio000444001750000144 507612544473514 16012 0ustar00nadimusers000000000000#!/usr/bin/env perl package main ; use strict; use warnings; use Glib ':constants'; use Gtk2 -init; Gtk2->init; use App::Asciio::GTK::Asciio ; use Module::Util qw(find_installed) ; use File::Basename ; #----------------------------------------------------------------------------- my $window = Gtk2::Window->new('toplevel'); $window->set_title("asciio"); $window->set_default_size(700, 800) ; $window->signal_connect("destroy", sub { exit(0); }); my $vbox = Gtk2::VBox->new (FALSE, 0); $window->add($vbox); my $hpaned = Gtk2::HPaned->new; $vbox->pack_start($hpaned, TRUE, TRUE, 0); $hpaned->set_border_width (3); my @asciios ; my $asciio = new App::Asciio::GTK::Asciio(50, 25) ; push @asciios, $asciio ; $hpaned->add1($asciio->{widget}); $vbox->show_all(); my ($command_line_switch_parse_ok, $command_line_parse_message, $asciio_config) = $asciio->ParseSwitches([@ARGV], 0) ; die "Error: '$command_line_parse_message'!" unless $command_line_switch_parse_ok ; my $setup_paths = [] ; if(@{$asciio_config->{SETUP_PATHS}}) { $setup_paths = $asciio_config->{SETUP_PATHS} ; } else { my ($basename, $path, $ext) = File::Basename::fileparse(find_installed('App::Asciio'), ('\..*')) ; my $setup_path = $path . $basename . '/setup/' ; $setup_paths = [ $setup_path . 'setup.ini', $setup_path . 'GTK/setup.ini', ] ; } $asciio->setup($setup_paths) ; my ($character_width, $character_height) = $asciio->get_character_size() ; if(defined $asciio_config->{TARGETS}[0]) { $asciio->run_actions_by_name(['Open', $asciio_config->{TARGETS}[0]]) ; $window->set_default_size(@{$asciio->{WINDOW_SIZE}}) if defined $asciio->{WINDOW_SIZE} ; } $window->show(); $asciio->set_modified_state(0) ; $asciio->run_script($asciio_config->{SCRIPT}) ; #-------------------------------------------------------------------------- $window->signal_connect (delete_event => \&delete_event, \@asciios) ; sub delete_event { my ($window, $event, $asciios) = @_; my $answer = 'yes'; my $should_save ; for my $asciio (@{$asciios}) { $should_save++ if $asciio->get_modified_state() ; } if($should_save) { $answer = $asciios[0]->display_quit_dialog('asciio', ' ' x 25 . "Document is modified!\n\nAre you sure you want to quit and lose your changes?\n") ; } if($answer eq 'save_and_quit') { for my $asciio (@{$asciios}) { my @saved_result = $asciio->run_actions_by_name('Save') ; $answer = 'cancel' if(! defined $saved_result[0][0] || $saved_result[0][0] eq '') ; } } return $answer eq 'cancel'; } #-------------------------------------------------------------------------- Gtk2->main(); App-Asciio-1.51.3/script/asciio_to_text000444001750000144 215112544473514 17547 0ustar00nadimusers000000000000#!/usr/bin/env perl package main ; use strict; use warnings; use App::Asciio ; use Module::Util qw(find_installed) ; use File::Basename ; #----------------------------------------------------------------------------- my @asciios ; my $asciio = new App::Asciio() ; push @asciios, $asciio ; my ($command_line_switch_parse_ok, $command_line_parse_message, $asciio_config) = $asciio->ParseSwitches([@ARGV], 0) ; die "Error: '$command_line_parse_message'!" unless $command_line_switch_parse_ok ; my $setup_paths = [] ; if(@{$asciio_config->{SETUP_PATHS}}) { $setup_paths = $asciio_config->{SETUP_PATHS} ; } else { my ($basename, $path, $ext) = File::Basename::fileparse(find_installed('App::Asciio'), ('\..*')) ; my $setup_path = $path . $basename . '/setup/' ; $setup_paths = [ $setup_path . 'setup.ini', ] ; } $asciio->setup($setup_paths) ; if(defined $asciio_config->{TARGETS}[0]) { $asciio->run_actions_by_name(['Open', $asciio_config->{TARGETS}[0]]) ; } $asciio->set_modified_state(0) ; $asciio->run_script($asciio_config->{SCRIPT}) ; print $asciio->transform_elements_to_ascii_buffer() ;