0001: #!/usr/bin/perl -w
0002: #!/usr/bin/perl -d:ptkdb -w
0003: ##
0004: ## Neurospaces: a library which implements a global typed symbol table to
0005: ## be used in neurobiological model maintenance and simulation.
0006: ##
0007: ## $Id: morphology2ndf 1.54 Wed, 14 Nov 2007 14:41:50 -0600 hugo $
0008: ##
0009: 
0010: ##############################################################################
0011: ##'
0012: ##' Neurospaces : testbed C implementation that integrates with genesis
0013: ##'
0014: ##' Copyright (C) 1999-2008 Hugo Cornelis
0015: ##'
0016: ##' functional ideas .. Hugo Cornelis, hugo.cornelis@gmail.com
0017: ##'
0018: ##' coding ............ Hugo Cornelis, hugo.cornelis@gmail.com
0019: ##'
0020: ##############################################################################
0021: 
0022: 
0023: =head1 INTERNAL FUNCTIONALITY
0024: 
0025: This section describes internals of this file.  It may or may not be
0026: correct.
0027: 
0028: 
0029: =cut
0030: 
0031: =head2 C<$ARGV[0]>
0032: 
0033: file to convert to neurospaces-description-format, if not supplied or
0034: only '-', reads from stdin.
0035: 
0036: =cut
0037: 
0038: 
0039: use strict;
0040: 
0041: 
0042: my $option_configuration_filename;
0043: my $option_configuration_template;
0044: my $option_force_library;
0045: my $option_optional_configuration_filename;
0046: my $option_output_format = 'ndf';
0047: # my $option_prototype_configuration;
0048: my $option_set_name;
0049: my $option_shrinkage;
0050: my $option_soma_offset;
0051: my $option_spine_prototypes = [];
0052: my $option_no_use_library;
0053: my $option_verbose;
0054: my $option_yaml = 0;
0055: 
0056: 
0057: my $cellname;
0058: 
0059: my $converted_aliasses = {};
0060: 
0061: my $line_count = 1;
0062: 
0063: my $morphology = {};
0064: 
0065: my $previous = {};
0066: 
0067: my $source_type;
0068: 
0069: 
0070: my $configuration;
0071: 
0072: my $variables;
0073: 
0074: 
0075: my $input_formats
0076:     = {
0077: #        '.ndf' => {
0078: #                 description => "neurospaces description format",
0079: #                 suffix => ".ndf",
0080: #                },
0081:        '.p' => {
0082:                 description => "genesis morphology file",
0083:                 suffix => ".p",
0084:                },
0085:        '.swc' => {
0086:                   description => ".swc file (can you give me a better description please ?)",
0087:                   suffix => ".swc",
0088:                  },
0089:       };
0090: 
0091: my $output_formats
0092:     = {
0093:        ndf => {
0094:                description => "neurospaces description format",
0095:                suffix => ".ndf",
0096:               },
0097: #        off => {
0098: #              description => "geomview edges/faces format",
0099: #              suffix => ".off",
0100: #             },
0101:       };
0102: 
0103: my $readcell_commands
0104:     = {
0105: 
0106:        # COMPARTMENT COORDINATES
0107: 
0108:        (
0109:         '*relative' => 'flag',
0110:         '*absolute' => 'flag',
0111:         '*polar' => 'flag',
0112:         '*cartesian' => 'flag',
0113:         '*lambda_warn' => {
0114:                            arguments => [
0115:                                          'MIN',
0116:                                          'MAX',
0117:                                         ],
0118:                            type => 'algorithm',
0119:                           },
0120:         '*lambda_unwarn' => 'flag',
0121:         '*double_endpoint' => 'flag',
0122:         '*double_endpoint_off' => 'flag',
0123:         '*origin' => {
0124:                       type => 'variable',
0125:                       variables => {
0126:                                     origin => 1,
0127:                                    },
0128:                      },
0129:        ),
0130: 
0131:        # COMPARTMENT SHAPE
0132: 
0133:        (
0134:         '*spherical' => 'flag',
0135:         '*cylindrical' => 'flag',
0136:         '*symmetric' => 'ignore',
0137:         '*asymmetric' => 'ignore',
0138:        ),
0139: 
0140:        # PARAMETER VALUES
0141: 
0142:        (
0143:         '*set_compt_param' => {
0144:                                type => 'variable',
0145:                                variables => {
0146:                                              CM => 1,
0147:                                              ELEAK => 1,
0148:                                              EREST_ACT => 1,
0149:                                              RA => 1,
0150:                                              RM => 1,
0151:                                             },
0152:                               },
0153:         '*set_global' => {
0154:                           type => 'variable',
0155:                           variables => {
0156:                                         CM => 1,
0157:                                         ELEAK => 1,
0158:                                         EREST_ACT => 1,
0159:                                         RA => 1,
0160:                                         RM => 1,
0161:                                        },
0162:                          },
0163:         '*start_cell' => {
0164:                           arguments => 'CELL_NAME',
0165:                           type => 'command',
0166:                          },
0167:         '*append_to_cell' => {
0168:                               arguments => 'CELL_NAME',
0169:                               type => 'command',
0170:                              },
0171:         '*makeproto' => {
0172:                          arguments => 'COMP_NAME',
0173:                          type => 'command',
0174:                         },
0175:         '*compt' => {
0176:                      type => 'prototype',
0177:                      arguments => 'PROTOTYPE',
0178:                     },
0179:         '*memb_factor' => {
0180:                            arguments => 'MEMB_FACTOR',
0181:                            type => 'algorithm',
0182:                           },
0183:         '*add_spines' => {
0184:                           arguments => [
0185:                                         'DENDR_DIAM',
0186:                                         'SPINE_DENS',
0187:                                         'SPINE_SUR',
0188:                                        ],
0189:                           type => 'algorithm',
0190:                          },
0191:         '*rand_spines' => {
0192:                            arguments => [
0193:                                          'DENDR_DIAM',
0194:                                          'SPINE_DENS',
0195:                                          'SPINE_SURF',
0196:                                          'AV_LENGTH',
0197:                                          'SPINE_FREQ',
0198:                                          'spine_proto',
0199:                                         ],
0200:                            processor =>
0201:                            sub
0202:                            {
0203:                                my $self = shift;
0204: 
0205:                                my $command = shift;
0206: 
0207:                                my $arguments = shift;
0208: 
0209:                                my $result;
0210: 
0211:                                $arguments =~ m'(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)';
0212: 
0213:                                my $DENDR_DIAM = $1;
0214:                                my $SPINE_DENS = $2;
0215:                                my $SPINE_SURF = $3;
0216:                                my $AV_LENGTH = $4;
0217:                                my $SPINE_FREQ = $5;
0218:                                my $spine_proto = $6;
0219: 
0220:                                $spine_proto =~ s(.*/)();
0221: 
0222:                                my $instance_name = "Spines__${DENDR_DIAM}__${SPINE_DENS}__${SPINE_SURF}__${AV_LENGTH}__${SPINE_FREQ}__${spine_proto}";
0223: 
0224:                                $instance_name =~ s/\./_/g;
0225: 
0226:                                $result = <<EOT;
0227: 
0228: ALGORITHM Spines
0229:         $instance_name
0230:         PARAMETERS
0231:                 PARAMETER ( PROTOTYPE = "$spine_proto" ),
0232:                 PARAMETER ( DIA_MIN = 0.00 ),
0233:                 PARAMETER ( DIA_MAX = $DENDR_DIAM ),
0234:                 PARAMETER ( SPINE_DENSITY = $SPINE_DENS ),
0235:                 PARAMETER ( SPINE_FREQUENCY = $SPINE_FREQ ),
0236:         END PARAMETERS
0237: END ALGORITHM
0238: EOT
0239: 
0240:                                my $spine_prototypes = $configuration->{prototypes}->{spine_prototypes};
0241: 
0242:                                # if there are no spine prototypes in the config
0243: 
0244:                                if (!@{$spine_prototypes || [] })
0245:                                {
0246:                                    # convert the algorithm reference
0247: 
0248:                                    return $result;
0249:                                }
0250: 
0251:                                # else
0252: 
0253:                                else
0254:                                {
0255:                                    # spines are only added according to the configuration, but not here
0256: 
0257:                                    return '';
0258:                                }
0259:                            },
0260:                            type => 'algorithm',
0261:                           },
0262:         '*mrand_spines' => {
0263:                             arguments => [
0264:                                           'DENDR_MIN',
0265:                                           'DENDR_DIAM',
0266:                                           'SPINE_DENS',
0267:                                           'SPINE_SURF',
0268:                                           'AV_LENGTH',
0269:                                           'SPINE_FREQ',
0270:                                           'spine_proto',
0271:                                          ],
0272:                             type => 'algorithm',
0273:                            },
0274:         '*fixed_spines' => {
0275:                             arguments => [
0276:                                           'DENDR_DIAM',
0277:                                           'SPINE_NUM',
0278:                                           'SPINE_SURF',
0279:                                           'SPINE_SKIP',
0280:                                           'spine_proto',
0281:                                          ],
0282:                             type => 'algorithm',
0283:                            },
0284:         '*mfixed_spines' => {
0285:                              arguments => [
0286:                                            'DENDR_MIN',
0287:                                            'DENDR_DIAM',
0288:                                            'SPINE_NUM',
0289:                                            'SPINE_SURF',
0290:                                            'SPINE_SKIP',
0291:                                            'spine_proto',
0292:                                           ],
0293:                              type => 'algorithm',
0294:                             },
0295:         '*rand_branches' => {
0296:                              arguments => [
0297:                                            'MAX_DIA',
0298:                                            'RAND_FREQ',
0299:                                            'NUM_ORDERS',
0300:                                            'POSTFIX',
0301:                                            'NUM_COMPS',
0302:                                            'MIN_L',
0303:                                            'MAX_L',
0304:                                            'MIN_D',
0305:                                            'MAX_D',
0306:                                            (
0307:                                             '[NUM_COMPS',
0308:                                             'MIN_L',
0309:                                             'MAX_L',
0310:                                             'MIN_D',
0311:                                             'MAX_D]',
0312:                                            ),
0313:                                           ],
0314:                              type => 'algorithm',
0315:                             },
0316:        ),
0317:       };
0318: 
0319: 
0320: package Data;
0321: 
0322: sub merge
0323: {
0324:     my $target = shift;
0325: 
0326:     my $source = shift;
0327: 
0328:     my $options = shift;
0329: 
0330:     # copy the detransformed values into the contents data.
0331: 
0332:     #
0333:     # subs to merge two datastructures.
0334:     #
0335: 
0336:     local $Data::data_merger_any
0337:         = sub
0338:           {
0339:               my $contents = shift;
0340: 
0341:               my $data = shift;
0342: 
0343:               # simply check what kind of data structure we are dealing
0344:               # with and forward to the right sub.
0345: 
0346:               my $type = ref $contents;
0347: 
0348:               if ($type eq 'HASH')
0349:               {
0350:                   &$Data::data_merger_hash($contents, $data);
0351:               }
0352:               elsif ($type eq 'ARRAY')
0353:               {
0354:                   &$Data::data_merger_array($contents, $data);
0355:               }
0356:               else
0357:               {
0358:                   die "$0: *** Error: Document error: data_merger_any encounters an unknown data type $type";
0359:               }
0360:           };
0361: 
0362:     local $Data::data_merger_hash
0363:         = sub
0364:           {
0365:               my $contents = shift;
0366: 
0367:               my $data = shift;
0368: 
0369:               # loop over all values in the contents hash.
0370: 
0371:               foreach my $section (keys %$data)
0372:               {
0373:                   if (exists $contents->{$section})
0374:                   {
0375:                       my $value = $data->{$section};
0376: 
0377:                       my $contents_type = ref $contents->{$section};
0378:                       my $value_type = ref $value;
0379: 
0380:                       if ($contents_type && $value_type)
0381:                       {
0382:                           if ($contents_type eq $value_type)
0383:                           {
0384:                               # two references of the same type, go one
0385:                               # level deeper.
0386: 
0387:                               &$Data::data_merger_any($contents->{$section}, $value);
0388:                           }
0389:                           else
0390:                           {
0391:                               die "$0: *** Error: Document error: contents_type is '$contents_type' and does not match with value_type $value_type";
0392:                           }
0393:                       }
0394:                       elsif (!$contents_type && !$value_type)
0395:                       {
0396:                           # copy scalar value
0397: 
0398:                           $contents->{$section} = $value;
0399:                       }
0400:                       else
0401:                       {
0402:                           die "$0: *** Error: Document error: contents_type is '$contents_type' and does not match with value_type $value_type";
0403:                       }
0404:                   }
0405:                   else
0406:                   {
0407:                       #t could be a new key being added.
0408:                   }
0409:               }
0410:           };
0411: 
0412:     local $Data::data_merger_array
0413:         = sub
0414:           {
0415:               my $contents = shift;
0416: 
0417:               my $data = shift;
0418: 
0419:               # loop over all values in the contents array.
0420: 
0421:               my $count = 0;
0422: 
0423:               foreach my $section (@$data)
0424:               {
0425:                   if (exists $contents->[$count]
0426:                       || $options->{arrays}->{overwrite} eq 1)
0427:                   {
0428:                       my $value = $data->[$count];
0429: 
0430:                       my $contents_type = ref $contents->[$count];
0431:                       my $value_type = ref $value;
0432: 
0433:                       if ($contents_type && $value_type)
0434:                       {
0435:                           if ($contents_type eq $value_type)
0436:                           {
0437:                               # two references of the same type, go one
0438:                               # level deeper.
0439: 
0440:                               &$Data::data_merger_any($contents->[$count], $value);
0441:                           }
0442:                           else
0443:                           {
0444:                               die "$0: *** Error: Document error: contents_type is '$contents_type' and does not match with value_type $value_type";
0445:                           }
0446:                       }
0447:                       elsif (!$contents_type && $value_type
0448:                              && $options->{arrays}->{overwrite} eq 1)
0449:                       {
0450:                           # overwrite array content
0451: 
0452:                           $contents->[$count] = $value;
0453:                       }
0454:                       elsif (!$contents_type && !$value_type)
0455:                       {
0456:                           # copy scalar value
0457: 
0458:                           $contents->[$count] = $value;
0459:                       }
0460:                       else
0461:                       {
0462:                           die "$0: *** Error: Document error: contents_type is '$contents_type' and does not match with value_type $value_type";
0463:                       }
0464:                   }
0465:                   else
0466:                   {
0467:                       #t could be a new key being added.
0468:                   }
0469: 
0470:                   $count++;
0471:               }
0472:           };
0473: 
0474:     #t Should actually use a simple iterator over the detransformed data
0475:     #t that keeps track of examined paths.  Then use the path to store
0476:     #t encountered value in the original data.
0477: 
0478:     #t Note that the iterator is partly implemented in Sesa::Transform and
0479:     #t Sesa::TreeDocument.  A further abstraction could be useful.
0480: 
0481:     # first inductive step : merge all data.
0482: 
0483:     &$Data::data_merger_hash($target, $source);
0484: 
0485:     return $target;
0486: }
0487: 
0488: 
0489: package main;
0490: 
0491: sub main
0492: {
0493:     read_cmd_line();
0494: 
0495:     # read file
0496: 
0497:     local $/;
0498: 
0499:     $_ = <>;
0500: 
0501:     if (!defined)
0502:     {
0503:         die "$0: *** Error: Error reading input (file not found ?)";
0504:     }
0505: 
0506:     # generate a preamble, initialize output_state
0507: 
0508:     my $output_state = output({ name => $option_set_name || $cellname, }, 'initialize', );
0509: 
0510: 
0511:     # convert, line by line
0512: 
0513:     #! (readcell also processes its files line by line, with numerous bugs
0514:     #! as a result, with some luck I introduce the same bugs overhere,
0515:     #! i.e. the same behavior.
0516: 
0517:     my @lines = split '\n';
0518: 
0519:     foreach my $line (@lines)
0520:     {
0521:         if ($source_type =~ /genesis/)
0522:         {
0523:             # remove single line comments
0524: 
0525:             #! probably should keep the comments
0526: 
0527:             $line =~ s(//.*)();
0528: 
0529:             # a command
0530: 
0531:             if ($line =~ /^(\*\S*)\s*(.*)/)
0532:             {
0533:                 my $command = $1;
0534: 
0535:                 my $arguments = $2;
0536: 
0537:                 $arguments =~ s(\s*//.*$)();
0538: 
0539:                 my $result = process_command($command, $arguments);
0540: 
0541:                 if (defined $result)
0542:                 {
0543:                     $output_state = output($output_state, 'commands', $result);
0544:                 }
0545:             }
0546:             elsif ($line =~ /^(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s*/)
0547:             {
0548:                 my $segment = $1;
0549: 
0550:                 my $parent = $2;
0551: 
0552:                 my $x = $3 * 1e-6;
0553:                 my $y = $4 * 1e-6;
0554:                 my $z = $5 * 1e-6;
0555:                 my $dia = $6 * 1e-6;
0556: 
0557:                 if ($parent eq '.')
0558:                 {
0559:                     $parent = $previous->{segment};
0560:                 }
0561: 
0562:                 if (exists $morphology->{$segment})
0563:                 {
0564:                     die "$0: *** Error: Multiple segments with the same name ($segment)";
0565:                 }
0566: 
0567:                 $morphology->{$segment}
0568:                     = {
0569:                        geometry => {
0570:                                     x => $x,
0571:                                     y => $y,
0572:                                     z => $z,
0573:                                     dia => $dia,
0574:                                    },
0575:                        parent => $parent,
0576:                       };
0577: 
0578:                 my $result = process_segment($segment, $parent, $x, $y, $z, $dia);
0579: 
0580:                 if (defined $result)
0581:                 {
0582:                     $output_state = output($output_state, 'segments', $result);
0583:                 }
0584: 
0585:                 $previous
0586:                     = {
0587:                        'segment' => $segment,
0588:                        'x' => $x,
0589:                        'y' => $y,
0590:                        'z' => $z,
0591:                        'dia' => $dia,
0592:                       };
0593:             }
0594:             elsif ($line =~ /^\s*/)
0595:             {
0596:             }
0597:             elsif ($line =~ /^(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s*/)
0598:             {
0599:                 # double endpoint not supported
0600: 
0601:                 print STDERR "$0: *** error: double endpoints and active mechanisms are not supported for conversion of genesis based morphologies (line $line_count).\n";
0602:             }
0603:             else
0604:             {
0605:                 # something else not yet supported
0606: 
0607:                 print STDERR "$0: *** error: found something not supported for conversion of genesis based morphologies ($line).\n";
0608:             }
0609:         }
0610:         elsif ($source_type =~ /swc/)
0611:         {
0612:             # remove single line comments
0613: 
0614:             #! probably should keep the comments
0615: 
0616:             $line =~ s(#.*)();
0617: 
0618:             # parse point line
0619: 
0620:             if ($line =~ /^\s*(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s*/)
0621:             {
0622:                 my $segment_number = $1;
0623: 
0624:                 #t this is currently a guess
0625: 
0626:                 #t looked up on the neuronland website, dia vs radius
0627:                 #t not sure if this applies also to the soma, given by $2 ?
0628: 
0629:                 my $tag = $2;
0630: 
0631:                 my $x = $3 * 1e-6;
0632:                 my $y = $4 * 1e-6;
0633:                 my $z = $5 * 1e-6;
0634:                 my $dia = $6 * 1e-6 * 2;
0635: 
0636:                 my $parent_number = $7;
0637: 
0638:                 # convert names to something neurospaces can work with
0639: 
0640:                 my $segment;
0641: 
0642:                 my $parent;
0643: 
0644:                 if ($parent_number eq -1)
0645:                 {
0646:                     $segment = "soma";
0647: 
0648:                     $parent = "none";
0649: 
0650:                     $morphology->{conversion}->{"s_$segment_number"} = "soma";
0651:                 }
0652:                 else
0653:                 {
0654:                     $segment = "s_$segment_number";
0655: 
0656:                     $parent = $morphology->{conversion}->{"s_$parent_number"} || "s_$parent_number";
0657: 
0658:                 }
0659: 
0660:                 #! actually for genesis, but you never know where and how some things propagate
0661: 
0662:                 if ($parent_number eq '.')
0663:                 {
0664:                     $parent = $previous->{segment};
0665:                 }
0666: 
0667:                 if (exists $morphology->{$segment})
0668:                 {
0669:                     die "$0: *** Error: Multiple segments with the same number ($segment_number)";
0670:                 }
0671: 
0672:                 $morphology->{$segment}
0673:                     = {
0674:                        geometry => {
0675:                                     x => $x,
0676:                                     y => $y,
0677:                                     z => $z,
0678:                                     dia => $dia,
0679:                                    },
0680:                        parent => $parent,
0681:                        tag => $tag,
0682:                       };
0683: 
0684:                 my $result = process_segment($segment, $parent, $x, $y, $z, $dia, $tag);
0685: 
0686:                 if (defined $result)
0687:                 {
0688:                     $output_state = output($output_state, 'segments', $result);
0689:                 }
0690: 
0691:                 $previous
0692:                     = {
0693:                        'segment' => $segment,
0694:                        'x' => $x,
0695:                        'y' => $y,
0696:                        'z' => $z,
0697:                        'dia' => $dia,
0698:                       };
0699:             }
0700:             elsif ($line =~ /^\s*/)
0701:             {
0702:             }
0703:             else
0704:             {
0705:                 # something else not yet supported
0706: 
0707:                 print STDERR "$0: *** error: found something not supported for conversion of genesis based morphologies ($line).\n";
0708:             }
0709:         }
0710: 
0711:         $line_count++;
0712:     }
0713: 
0714:     $output_state = output($output_state, 'finish', );
0715: 
0716:     if ($option_yaml)
0717:     {
0718:         use YAML;
0719: 
0720:         print Dump($morphology);
0721:     }
0722: 
0723:     if ($output_state)
0724:     {
0725:         1;
0726:     }
0727:     else
0728:     {
0729:         0;
0730:     }
0731: }
0732: 
0733: 
0734: sub output
0735: {
0736:     my $output_state = shift;
0737: 
0738:     my $command = shift;
0739: 
0740:     my $string = shift;
0741: 
0742:     # if initializing
0743: 
0744:     if (!$output_state->{initialized})
0745:     {
0746:         my $name = $output_state->{name};
0747: 
0748:         my $date = gmtime();
0749: 
0750:         my $imports = "";
0751: 
0752:         my $private_models = "";
0753: 
0754:         my $prototype_configuration = $configuration->{prototypes};
0755: 
0756:         if ($prototype_configuration->{aliasses})
0757:         {
0758: #           my $aliasses = $prototype_configuration->{aliasses};
0759: 
0760:             $imports = "
0761: IMPORT
0762: 
0763: ";
0764: 
0765:             $private_models = "
0766: PRIVATE_MODELS
0767: 
0768: ";
0769: 
0770:             my $index = 'a';
0771: 
0772:             foreach my $modelname (sort keys %$converted_aliasses)
0773:             {
0774:                 my $filename = $converted_aliasses->{$modelname};
0775: 
0776:                 my $namespace = $index;
0777: 
0778:                 $imports .= "   FILE $namespace \"$filename\"
0779: ";
0780:                 $private_models .= "    ALIAS ${namespace}::/$modelname $modelname END ALIAS
0781: ";
0782: 
0783:                 $index++;
0784:             }
0785: 
0786:             $imports .= "
0787: END IMPORT
0788: ";
0789:         
0790:             $private_models .= "
0791: END PRIVATE_MODELS
0792: ";
0793: 
0794:         }
0795: 
0796:         my $yaml_configuration = '';
0797: 
0798:         {
0799:             use YAML;
0800: 
0801:             $yaml_configuration = Dump($configuration);
0802: 
0803:             $yaml_configuration = join "\n", map { "// $_" } split "\n", $yaml_configuration;
0804:         }
0805: 
0806:         # loop over all possible interpreter_sequences
0807: 
0808:         #! last is default
0809: 
0810:         my $interpreter_sequence = "/usr/local/bin/neurospacesparse";
0811: 
0812:         foreach my $interpreter (
0813:                                  qw(
0814:                                     /opt/bin/neurospacesparse
0815:                                     /usr/bin/neurospacesparse
0816:                                     /usr/local/bin/neurospacesparse
0817:                                    )
0818:                                 )
0819:         {
0820:             if (-e $interpreter)
0821:             {
0822:                 $interpreter_sequence = $interpreter;
0823: 
0824:                 last;
0825:             }
0826:         }
0827: 
0828:         my $output
0829:             = "#!$interpreter_sequence
0830: // -*- NEUROSPACES -*-
0831: // Neurospaces morphology file for a neuron
0832: // converted by $0, $date
0833: //
0834: // $0 configuration follows:
0835: //
0836: $yaml_configuration
0837: //
0838: 
0839: NEUROSPACES NDF
0840: $imports
0841: $private_models
0842: 
0843: PUBLIC_MODELS
0844: 
0845:         CELL $name
0846: ";
0847: 
0848:         $output_state->{initialized} = 1;
0849:         $output_state->{preamble} = $output;
0850:     }
0851: 
0852:     # process string to output
0853: 
0854:     if (defined $string)
0855:     {
0856:         # proper indent
0857: 
0858:         my $indent = "\t";
0859: 
0860:         if ($command eq 'segments')
0861:         {
0862:             #! add indent for segment group
0863: 
0864:             $indent .= "\t\t";
0865:         }
0866: 
0867:         $string =~ s/^/$indent/mg;
0868: 
0869:         # remember to output in the correct section
0870: 
0871:         $output_state->{$command} .= $string;
0872:     }
0873: 
0874:     # if output terminating
0875: 
0876:     if ($command eq 'finish')
0877:     {
0878:         if ($option_yaml)
0879:         {
0880:             return undef;
0881:         }
0882: 
0883:         # print preamble
0884: 
0885:         print $output_state->{preamble} || "";
0886: 
0887:         # print commands (mainly algorithms)
0888: 
0889:         print $output_state->{commands} || "";
0890: 
0891:         # start segment group
0892: 
0893:         my $segment_group_name = "segments"; # "segments_$output_state->{name}";
0894: 
0895:         my $spine_prototypes = $configuration->{prototypes}->{spine_prototypes};
0896: 
0897:         my $count = 0;
0898: 
0899:         foreach my $spine_prototype ( @{ [ @{$spine_prototypes || []} ] } )
0900:         {
0901:             # replace colons and other stuff
0902: 
0903:             my $spine_label = $spine_prototype;
0904: 
0905:             $spine_label =~ s/::/_/g;
0906: 
0907:             my $fDendrDiaMin = $configuration->{algorithms}->{spines}->{fDendrDiaMin};
0908:             my $fDendrDiaMax = $configuration->{algorithms}->{spines}->{fDendrDiaMax};
0909:             my $fSpineDensity = $configuration->{algorithms}->{spines}->{fSpineDensity};
0910:             my $fSpineFrequency = $configuration->{algorithms}->{spines}->{fSpineFrequency};
0911: 
0912:             my $instance_name = "Spines__${count}__${spine_label}";
0913: 
0914:             print
0915: "
0916:                 ALGORITHM Spines
0917:                         $instance_name
0918:                         PARAMETERS
0919:                                 PARAMETER ( PROTOTYPE = \"$spine_prototype\" ),
0920:                                 PARAMETER ( DIA_MIN = $fDendrDiaMin ),
0921:                                 PARAMETER ( DIA_MAX = $fDendrDiaMax ),
0922:                                 PARAMETER ( SPINE_DENSITY = $fSpineDensity ),
0923:                                 PARAMETER ( SPINE_FREQUENCY = $fSpineFrequency ),
0924:                         END PARAMETERS
0925:                 END ALGORITHM
0926: ";
0927: 
0928:             $count++;
0929:         }
0930: 
0931:         print
0932: "
0933:                 SEGMENT_GROUP $segment_group_name
0934: 
0935: ";
0936: 
0937:         # print segments
0938: 
0939:         print $output_state->{segments};
0940: 
0941:         # end segment group
0942: 
0943:         print
0944: "
0945:                 END SEGMENT_GROUP
0946: 
0947: ";
0948: 
0949:         # print tail
0950: 
0951:         print
0952: "       END CELL
0953: 
0954: END PUBLIC_MODELS
0955: 
0956: ";
0957: 
0958:         # signal ok
0959: 
0960:         return undef;
0961:     }
0962: 
0963:     # else
0964: 
0965:     else
0966:     {
0967:         # return state for next output
0968: 
0969:         return $output_state;
0970:     }
0971: }
0972: 
0973: 
0974: sub process_command
0975: {
0976:     my $command = shift;
0977: 
0978:     my $arguments = shift;
0979: 
0980:     my $processed = 0;
0981: 
0982:     my $output;
0983: 
0984:     # if a command specification exists for this command
0985: 
0986:     if (exists $readcell_commands->{$command})
0987:     {
0988:         my $command_specifier = $readcell_commands->{$command};
0989: 
0990:         # for non structured specifications
0991: 
0992:         my $ref = ref $command_specifier;
0993: 
0994:         if (!$ref)
0995:         {
0996:             # process flags as variables
0997: 
0998:             if ($command_specifier eq 'flag')
0999:             {
1000:                 $variables->{$command} = 1;
1001: 
1002:                 $processed = 1;
1003:             }
1004: 
1005:             # process ignored commands
1006: 
1007:             elsif ($command_specifier eq 'ignore')
1008:             {
1009:                 $processed = 1;
1010:             }
1011:         }
1012: 
1013:         # for structured specifications
1014: 
1015:         elsif ($ref =~ m'HASH')
1016:         {
1017:             # look at the type of the command
1018: 
1019:             my $type = $command_specifier->{type};
1020: 
1021:             if ($type eq 'command')
1022:             {
1023:             }
1024: 
1025:             # needs to be converted to an algorithm ?
1026: 
1027:             elsif ($type eq 'algorithm')
1028:             {
1029:                 # call the command specific processor
1030: 
1031:                 my $processor = $command_specifier->{processor};
1032: 
1033:                 if (defined $processor)
1034:                 {
1035:                     $output = &$processor($command_specifier, $command, $arguments);
1036: 
1037:                     if (defined $output)
1038:                     {
1039:                         $processed = 1;
1040: 
1041:                         if ($output =~ m/spines/i)
1042:                         {
1043:                             my $has_spines = 1;
1044:                         }
1045:                     }
1046:                 }
1047:                 else
1048:                 {
1049:                     die "$0: *** Error: Attempted conversion of $command, but this is not supported yet.";
1050:                 }
1051:             }
1052: 
1053:             # related to variables ?
1054: 
1055:             elsif ($type eq 'variable')
1056:             {
1057:                 # set the variable
1058: 
1059:                 $arguments =~ /(\S*)\s+(\S*)/;
1060: 
1061:                 my $varname = $1;
1062: 
1063:                 my $value = $2;
1064: 
1065:                 $variables->{$varname} = $value;
1066: 
1067:                 $processed = 1;
1068:             }
1069: 
1070:             # setting the prototype ?
1071: 
1072:             elsif ($type eq 'prototype')
1073:             {
1074:                 # set the prototype
1075: 
1076:                 $arguments =~ m(.*/(\S*));
1077: 
1078:                 my $prototype = $1;
1079: 
1080:                 $variables->{prototype} = $prototype;
1081: 
1082:                 $processed = 1;
1083:             }
1084:         }
1085:     }
1086:     else
1087:     {
1088:         $processed = 1;
1089: 
1090:         print STDERR "Unknown command $command at line $line_count\n";
1091:     }
1092: 
1093:     if (!$processed)
1094:     {
1095:         print STDERR "Unknown command definition for $command at line $line_count (internal error)\n";
1096:     }
1097: 
1098:     return $output;
1099: }
1100: 
1101: 
1102: sub process_segment
1103: {
1104:     my ($segment, $parent, $x, $y, $z, $dia, $tag) = @_;
1105: 
1106:     if ($variables->{'*absolute'}
1107:        || $source_type =~ /swc/)
1108:     {
1109:         if ($parent eq 'none')
1110:         {
1111:             #! this is the way genesis does it, plain wrong but compatible.
1112: 
1113:             $x = $variables->{origin}->{'x'};
1114:             $y = $variables->{origin}->{'y'};
1115:             $z = $variables->{origin}->{'z'};
1116:         }
1117:         else
1118:         {
1119:             if (!exists $morphology->{$parent})
1120:             {
1121:                 die "$0: *** Error: $parent does not exist, but is used as parent";
1122:             }
1123:             else
1124:             {
1125:                 $x -= $morphology->{$parent}->{geometry}->{'x'};
1126:                 $y -= $morphology->{$parent}->{geometry}->{'y'};
1127:                 $z -= $morphology->{$parent}->{geometry}->{'z'};
1128:             }
1129:         }
1130:     }
1131: 
1132:     # if soma_offset option
1133: 
1134:     if ($configuration->{options}->{relocation}->{soma_offset})
1135:     {
1136:         # for a soma
1137: 
1138:         if ($parent eq 'none')
1139:         {
1140:             # register soma offset
1141: 
1142:             #! make sure we are working on a copy of the configuration
1143: 
1144:             $variables->{soma} = { %{$variables->{soma} || {}}, };
1145: 
1146:             $variables->{soma}->{x} = $x;
1147:             $variables->{soma}->{y} = $y;
1148:             $variables->{soma}->{z} = $z;
1149:         }
1150: 
1151:         # else
1152: 
1153:         else
1154:         {
1155:             # apply soma offset
1156: 
1157:             $x -= $variables->{soma}->{x};
1158:             $y -= $variables->{soma}->{y};
1159:             $z -= $variables->{soma}->{z};
1160:         }
1161:     }
1162: 
1163:     # do shrinkage correction
1164: 
1165:     #! so here we are working in relative coordinate mode
1166: 
1167:     if ($configuration->{options}->{histology}->{shrinkage} ne 1)
1168:     {
1169:         my $shrinkage = $configuration->{options}->{histology}->{shrinkage};
1170: 
1171:         $x *= $shrinkage;
1172:         $y *= $shrinkage;
1173:         $z *= $shrinkage;
1174: 
1175:         $dia *= $shrinkage;
1176:     }
1177: 
1178:     # default prototype: from global variables
1179: 
1180:     my $prototype = $variables->{prototype};
1181: 
1182:     # if prototype conversion requested
1183: 
1184:     my $prototype_index = 0;
1185: 
1186:     my $prototype_configuration = $configuration->{prototypes};
1187: 
1188:     if ($prototype_configuration->{parameter_2_prototype})
1189:     {
1190:         # if tag based conversion (eg. for swc files)
1191: 
1192:         my $parameter_2_prototype = $prototype_configuration->{parameter_2_prototype};
1193: 
1194:         if (exists $parameter_2_prototype->[0]->{tag})
1195:         {
1196:             # loop over all prototype relations (sorted to priority)
1197: 
1198:             foreach my $relation (@$parameter_2_prototype)
1199:             {
1200:                 if (defined $tag)
1201:                 {
1202:                     if (!defined $relation->{tag})
1203:                     {
1204:                         die "$0: invalid tag based configuration (all entries need a tag value)";
1205:                     }
1206: 
1207:                     # if the segment has this tag
1208: 
1209:                     if ($tag =~ /^("|'|)?$relation->{tag}\1$/)
1210:                     {
1211:                         # break loop
1212: 
1213:                         last;
1214:                     }
1215: 
1216:                     # increment prototype_index that we will assign to the segment
1217: 
1218:                     $prototype_index++;
1219:                 }
1220:             }
1221: 
1222:             # set prototype according to index
1223: 
1224:             if (exists $parameter_2_prototype->[$prototype_index])
1225:             {
1226:                 $prototype = $parameter_2_prototype->[$prototype_index]->{prototype};
1227:             }
1228:         }
1229: 
1230:         # else, diameter based conversion
1231: 
1232:         else
1233:         {
1234:             # loop over all prototype relations (sorted to priority)
1235: 
1236:             foreach my $relation (@$parameter_2_prototype)
1237:             {
1238:                 if (exists $relation->{dia})
1239:                 {
1240:                     # if the segment does not satisfy the relation
1241: 
1242:                     if ($dia < $relation->{dia})
1243:                     {
1244:                         # break loop
1245: 
1246:                         last;
1247:                     }
1248:                 }
1249: 
1250:                 # increment prototype_index that we will assign to the segment
1251: 
1252:                 $prototype_index++;
1253: 
1254:                 # if there is a parent
1255: 
1256:                 if (defined $parent
1257:                     && $parent ne 'none')
1258:                 {
1259:                     # if the parent has a lower prototype
1260: 
1261:                     if (exists $morphology->{$parent})
1262:                     {
1263:                         my $parent_prototype_index
1264:                             = defined $morphology->{$parent}->{prototype_index}
1265:                                 ? $morphology->{$parent}->{prototype_index}
1266:                                     : 10000;
1267: 
1268:                         if ($prototype_index > $parent_prototype_index)
1269:                         {
1270:                             # correct prototype
1271: 
1272:                             $prototype_index = $parent_prototype_index;
1273:                         }
1274:                     }
1275: 
1276:                     # if there is no parent
1277: 
1278:                     else
1279:                     {
1280:                         # force to be the soma
1281: 
1282:                         #! not really correct, but don't see any other way with
1283:                         #! genesis .p files, ie. genesis is broken by design in this matter
1284: 
1285:                         $prototype_index = $#$parameter_2_prototype;
1286:                     }
1287:                 }
1288:             }
1289: 
1290:             # set prototype according to index
1291: 
1292:             $prototype = $parameter_2_prototype->[$prototype_index]->{prototype};
1293: 
1294:             # if there is a parent
1295: 
1296:             if (defined $parent
1297:                 && $parent ne 'none')
1298:             {
1299:                 # if the parent has a lower prototype
1300: 
1301:                 if (exists $morphology->{$parent})
1302:                 {
1303:                     my $parent_prototype_index
1304:                         = defined $morphology->{$parent}->{prototype_index}
1305:                             ? $morphology->{$parent}->{prototype_index}
1306:                                 : 10000;
1307: 
1308:                     if ($prototype_index > $parent_prototype_index)
1309:                     {
1310:                         # correct prototype
1311: 
1312:                         $prototype_index = $parent_prototype_index;
1313:                     }
1314:                 }
1315:             }
1316: 
1317:             # if there is no parent
1318: 
1319:             else
1320:             {
1321:                 # force to be the soma
1322: 
1323:                 #! not really correct, but don't see any other way with
1324:                 #! genesis .p files, ie. genesis is broken by design in this matter
1325: 
1326:                 $prototype_index = $#$parameter_2_prototype;
1327:             }
1328: 
1329:             # set prototype according to index
1330: 
1331:             $prototype = $parameter_2_prototype->[$prototype_index]->{prototype};
1332: 
1333:         }
1334:     }
1335: 
1336:     # if there is a separate mapping to map individual segments to something special
1337: 
1338:     if ($prototype_configuration->{name_2_prototype})
1339:     {
1340:         # loop over all these mappings
1341: 
1342:         my $name_2_prototype = $prototype_configuration->{name_2_prototype};
1343: 
1344:         foreach my $name_mapper (@$name_2_prototype)
1345:         {
1346:             # if the segment name matches
1347: 
1348:             if (defined $name_mapper->{name}
1349:                 && $segment eq $name_mapper->{name})
1350:             {
1351:                 # set the prototype
1352: 
1353:                 $prototype = $name_mapper->{prototype};
1354:             }
1355:             elsif (defined $name_mapper->{regex}
1356:                    && $segment =~ /$name_mapper->{regex}/)
1357:             {
1358:                 $prototype = $name_mapper->{prototype};
1359:             }
1360:         }
1361:     }
1362: 
1363:     # loop over the somatopetal path
1364: 
1365:     my $path_somatopetal = [];
1366: 
1367:     my $somatopetal_neighbour = $parent;
1368: 
1369:     while (defined $somatopetal_neighbour
1370:            && $somatopetal_neighbour ne 'none')
1371:     {
1372:         # collect path info
1373: 
1374:         my $string = "$somatopetal_neighbour (";
1375: 
1376:         if (defined $morphology->{$somatopetal_neighbour}->{prototype})
1377:         {
1378:             $string .= $morphology->{$somatopetal_neighbour}->{prototype};
1379:         }
1380:         else
1381:         {
1382:             $string .= '__UNDEF__';
1383:         }
1384: 
1385:         $string .= ", $morphology->{$somatopetal_neighbour}->{geometry}->{'dia'})";
1386: 
1387:         push @$path_somatopetal, $string;
1388: 
1389:         $somatopetal_neighbour = $morphology->{$somatopetal_neighbour}->{parent};
1390:     }
1391: 
1392:     # fill in the morphology that we are going to use
1393: 
1394:     $morphology->{$segment}->{prototype} = $prototype;
1395: 
1396:     $morphology->{$segment}->{prototype_index} = $prototype_index;
1397: 
1398:     $morphology->{$segment}->{path_somatopetal} = $path_somatopetal;
1399: 
1400:     # fill in comments
1401: 
1402:     my $comments = "";
1403: 
1404:     # look for parent
1405: 
1406:     my $parent_parameter = $parent eq 'none' ? "" : "           PARAMETER ( PARENT = ^/$parent ),";
1407: 
1408:     # look for a tag (supported only by swc for the moment
1409: 
1410:     my $tag_parameter = defined $tag ? "                PARAMETER ( TAG = \"$tag\" ),\n" : "";
1411: 
1412:     # reformat the coordinates and the diameter
1413: 
1414:     #! to reproduce edsjb1994 as close as possible
1415: 
1416:     foreach my $parameter (qw(x y z dia))
1417:     {
1418:         my $value = eval "\$$parameter";
1419: 
1420:         # add the decimal point if none
1421: 
1422:         if ($value !~ /\./)
1423:         {
1424:             $value =~ s/^([-0-9]*)/$1.0/;
1425:         }
1426: 
1427:         # transform 1e-07 to 1e-06
1428: 
1429:         if ($value =~ /^([-0-9]+)\.([0-9]+)e-07$/)
1430:         {
1431:             my $integer = $1;
1432:             my $fraction = $2;
1433: 
1434:             $integer =~ s/^(.*)(.)$/$1/;
1435: 
1436:             my $shift = $2;
1437: 
1438:             if ($integer =~ /^$/)
1439:             {
1440:                 $integer = '0';
1441:             }
1442: 
1443:             if ($integer =~ /^-$/)
1444:             {
1445:                 $integer = '-0';
1446:             }
1447: 
1448:             $fraction = $shift . $fraction;
1449: 
1450:             $value = $integer . '.' . $fraction . 'e-06';
1451:         }
1452: 
1453:         # transform 1e-05 to 1e-06
1454: 
1455:         if ($value =~ /^([-0-9]+)\.([0-9]+)e-05$/)
1456:         {
1457:             my $integer = $1;
1458:             my $fraction = $2;
1459: 
1460:             $fraction =~ s/^(.)(.*)$/$2/;
1461: 
1462:             my $shift = $1;
1463: 
1464:             if ($fraction =~ /^$/)
1465:             {
1466:                 $fraction = '0';
1467:             }
1468: 
1469:             $integer = $integer . $shift;
1470: 
1471:             $value = $integer . '.' . $fraction . 'e-06';
1472:         }
1473: 
1474:         # make sure we have two ending digits for the diameter
1475: 
1476:         if ($value =~ /^([-0-9]+)\.([0-9]+)e-06$/
1477:             && $parameter eq 'dia')
1478:         {
1479:             my $integer = $1;
1480:             my $fraction = $2;
1481: 
1482:             if ($fraction =~ /^..$/)
1483:             {
1484:                 $fraction .= '';
1485:             }
1486: 
1487:             if ($fraction =~ /^.$/)
1488:             {
1489:                 $fraction .= '0';
1490:             }
1491: 
1492:             if ($fraction =~ /^$/)
1493:             {
1494:                 $fraction .= '00';
1495:             }
1496: 
1497:             $value = $integer . '.' . $fraction . 'e-06';
1498:         }
1499: 
1500:         # make sure we have three ending digits for the diameter
1501: 
1502:         if ($value =~ /^([-0-9]+)\.([0-9]+)e-06$/
1503:             && $parameter ne 'dia')
1504:         {
1505:             my $integer = $1;
1506:             my $fraction = $2;
1507: 
1508:             if ($fraction =~ /^..$/)
1509:             {
1510:                 $fraction .= '0';
1511:             }
1512: 
1513:             if ($fraction =~ /^.$/)
1514:             {
1515:                 $fraction .= '00';
1516:             }
1517: 
1518:             if ($fraction =~ /^$/)
1519:             {
1520:                 $fraction .= '000';
1521:             }
1522: 
1523:             $value = $integer . '.' . $fraction . 'e-06';
1524:         }
1525: 
1526:         # make sure we have a decimal point
1527: 
1528:         #t this one has become obsolete correct ?
1529: 
1530:         #t I need tests for all the functionality of this script
1531: 
1532:         if ($value =~ /^[0-9]*$/)
1533:         {
1534:             $value .= '.0';
1535:         }
1536: 
1537:         # treat zero point specially
1538: 
1539:         $value =~ s/^0.0$/0.000e-6/g;
1540: 
1541:         # not sure about this one
1542: 
1543:         $value =~ s/e-0*([0-9]+)/e-$1/g;
1544: 
1545:         #! note: force a string operation in the eval, otherwise perl
1546:         #! might efficiently remove trailing zeros, undoing what we
1547:         #! have done
1548: 
1549:         eval "\$$parameter = '$value'";
1550:     }
1551: 
1552:     if ($option_output_format eq 'ndf')
1553:     {
1554:         # produce ndf result
1555: 
1556:         if (defined $prototype)
1557:         {
1558:             my $result = <<EOT;
1559: ${comments}CHILD $prototype $segment
1560:         PARAMETERS
1561: $parent_parameter
1562:                 PARAMETER ( rel_X = $x ),
1563:                 PARAMETER ( rel_Y = $y ),
1564:                 PARAMETER ( rel_Z = $z ),
1565:                 PARAMETER ( DIA = $dia ),
1566: $tag_parameter  END PARAMETERS
1567: END CHILD
1568: EOT
1569: 
1570:             return $result;
1571:         }
1572:         else
1573:         {
1574:             return "
1575: // no prototype defined for $segment ($x, $y, $z, $dia)
1576: ";
1577:         }
1578:     }
1579: 
1580:     elsif ($option_output_format eq 'off')
1581:     {
1582:         return "$x $y $z";
1583:     }
1584: 
1585:     die "$0: *** Error: unknown output format ($option_output_format) in process_segment()";
1586: 
1587: }
1588: 
1589: 
1590: my $column_option_parser
1591:     = sub
1592:       {
1593:           my $option_name = shift;
1594: 
1595:           my $option_value = shift;
1596: 
1597:           # construct option name
1598: 
1599:           $option_name =~ s/-/_/g;
1600: 
1601:           $option_name = "\$option_$option_name";
1602: 
1603:           # loop over the specifications
1604: 
1605:           my $specifications = [ split '.', $option_value, ];
1606: 
1607:           #! disabled for the moment
1608: 
1609:           $specifications = [ $option_value, ];
1610: 
1611:           foreach my $specification (@$specifications)
1612:           {
1613:               # loop over columns
1614: 
1615:               my $values = [ split ',', $specification, ];
1616: 
1617:               # loop over all given values
1618: 
1619:               map
1620:               {
1621:                   # determine start and end (column)
1622: 
1623:                   my $start;
1624:                   my $end;
1625: 
1626:                   if (/([0-9]*)-([0-9]*)/)
1627:                   {
1628:                       $start = $1;
1629:                       $end = $2;
1630:                   }
1631:                   else
1632:                   {
1633:                       $start = $_;
1634:                       $end = $_;
1635:                   }
1636: 
1637:                   $start eq '' and $start = 1;
1638: 
1639:                   #! what to use as maximum ?
1640: 
1641:                   $end eq '' and $end = 1000;
1642: 
1643:                   # loop over the range in the given value
1644: 
1645:                   foreach ($start .. $end)
1646:                   {
1647:                       # offset the range
1648: 
1649:                       my $column = $_ - 1;
1650: 
1651:                       # store the given column
1652: 
1653:                       eval "${option_name}->{$column} = 1;"
1654:                   }
1655:               }
1656:                   # for each value given
1657: 
1658:                   @$values;
1659:           }
1660:       };
1661: 
1662: 
1663: sub read_cmd_line
1664: {
1665:     use Getopt::Long;
1666: 
1667:     my $option_help;
1668:     my $option_output_formats;
1669:     my $option_input_formats;
1670:     my $option_show_configuration;
1671:     my $option_show_library;
1672: 
1673:     my $result
1674:         = GetOptions
1675:             (
1676:              "accumulator-columns=s" => $column_option_parser,
1677:              "configuration-filename=s" => \$option_configuration_filename,
1678:              "configuration-template=s" => \$option_configuration_template,
1679:              "force-library!" => \$option_force_library,
1680:              "help!" => \$option_help,
1681:              "input-format-list!" => \$option_input_formats,
1682:              "optional-configuration-filename=s" => \$option_optional_configuration_filename,
1683:              "output-format=s" => \$option_output_format,
1684:              "output-format-list!" => \$option_output_formats,
1685: #            "prototypes=s" => \$option_prototype_configuration,
1686:              "set-name=s" => \$option_set_name,
1687:              "show-configuration" => \$option_show_configuration,
1688:              "show-library" => \$option_show_library,
1689:              "shrinkage=s", => \$option_shrinkage,
1690:              "soma-offset!" => \$option_soma_offset,
1691:              "spine-prototypes=s" => $option_spine_prototypes,
1692:              "no-use-library!" => \$option_no_use_library,
1693:              "v|verbose+" => \$option_verbose,
1694:              "y|yaml" => \$option_yaml,
1695:             );
1696: 
1697:     my $default_configuration
1698:         = {
1699:            prototypes => {
1700:                           aliasses => [
1701:                                        'segments/purkinje_spinyd_passive.ndf::spinyd',
1702:                                       ],
1703:                           parameter_2_prototype => [
1704:                                                     {
1705:                                                      dia => 1,
1706:                                                      prototype => 'spinyd',
1707:                                                     },
1708:                                                    ],
1709:                           spine_prototypes => [],
1710:                          },
1711:            variables => {
1712:                          origin => {
1713:                                     x => 0,
1714:                                     y => 0,
1715:                                     z => 0,
1716:                                    },
1717:                         },
1718:            options => {
1719:                        histology => {
1720:                                      shrinkage => 1,
1721:                                     },
1722:                        relocation => {
1723:                                       soma_offset => 1,
1724:                                      },
1725:                       },
1726:           };
1727: 
1728:     my $configuration_templates
1729:         = {
1730:            purkinje => {
1731:                         prototypes => {
1732:                                        aliasses => [
1733:                                                     "segments/spines/purkinje.ndf::Purk_spine",
1734:                                                     'segments/purkinje/maind.ndf::maind',
1735:                                                     'segments/purkinje/soma.ndf::soma',
1736:                                                     'segments/purkinje/spinyd.ndf::spinyd',
1737:                                                     'segments/purkinje/thickd.ndf::thickd',
1738:                                                    ],
1739:                                        parameter_2_prototype => [
1740:                                                                  {
1741:                                                                   dia => 3.18e-6,
1742:                                                                   prototype => 'spinyd',
1743:                                                                  },
1744:                                                                  {
1745:                                                                   dia => 7.71e-6,
1746:                                                                   prototype => 'thickd',
1747:                                                                  },
1748:                                                                  {
1749:                                                                   dia => 2.8e-5,
1750:                                                                   prototype => 'maind',
1751:                                                                  },
1752:                                                                  {
1753:                                                                   dia => 1,
1754:                                                                   prototype => 'soma',
1755:                                                                  },
1756:                                                                 ],
1757:                                        spine_prototypes => [],
1758:                                       },
1759:                         variables => {
1760:                                       origin => {
1761:                                                  x => 0,
1762:                                                  y => 0,
1763:                                                  z => 0,
1764:                                                 },
1765:                                      },
1766:                         options => {
1767:                                     histology => {
1768:                                                   shrinkage => 1,
1769:                                                  },
1770:                                     relocation => {
1771:                                                    soma_offset => 1,
1772:                                                   },
1773:                                    },
1774:                        },
1775:           };
1776: 
1777:     if (defined $option_configuration_template)
1778:     {
1779:         if (exists $configuration_templates->{$option_configuration_template})
1780:         {
1781:             $default_configuration = $configuration_templates->{$option_configuration_template};
1782:         }
1783:         else
1784:         {
1785:             die "$0: configuration_template $option_configuration_template does not exist.";
1786:         }
1787:     }
1788: 
1789:     use YAML 'LoadFile';
1790: 
1791:     my $morphology2ndf_configuration;
1792: 
1793:     if (!$option_no_use_library)
1794:     {
1795:         eval
1796:         {
1797:             $morphology2ndf_configuration = LoadFile("/etc/neurospaces/morphology2ndf/morphology2ndf.yml");
1798:         };
1799:     }
1800: 
1801:     $configuration = $morphology2ndf_configuration->{morphology2ndf} || $default_configuration;
1802: 
1803:     my $config_variables = $configuration->{variables};
1804: 
1805:     $variables
1806:         = {
1807:            %$config_variables,
1808:           };
1809: 
1810:     if ($option_input_formats)
1811:     {
1812:         use YAML;
1813: 
1814:         print Dump({ "input formats known by $0" => $input_formats, }, );
1815: 
1816:         exit 0;
1817:     }
1818: 
1819:     if ($option_output_formats)
1820:     {
1821:         use YAML;
1822: 
1823:         print Dump({ "output formats known by $0" => $output_formats, }, );
1824: 
1825:         exit 0;
1826:     }
1827: 
1828:     if (!exists $output_formats->{$option_output_format})
1829:     {
1830:         print "*** Error: unknown output format $option_output_format\n\n";
1831: 
1832:         use YAML;
1833: 
1834:         print Dump({ "output formats known by $0" => $output_formats, }, );
1835: 
1836:         exit 0;
1837:     }
1838: 
1839:     if ($option_show_library)
1840:     {
1841:         use YAML;
1842: 
1843:         print Dump($configuration->{library});
1844: 
1845:         exit 0;
1846:     }
1847: 
1848:     if ($option_help
1849:         || (!@ARGV
1850:             && !$option_show_configuration))
1851:     {
1852:         print
1853:             "
1854: $0 <options> <genesis .p file | .swc file>
1855: 
1856: $0: convert morphology files to neurospaces morphology files.
1857: 
1858: options :
1859:     --configuration-filename  configuration filename (if none, a default configuration is used,
1860:                                 or a library configuration (in /etc) is used,
1861:                                 use the show-configuration option to see what it looks like).
1862:     --force-library           force the use of library values, ignoring command line options.
1863:     --help                    print usage information.
1864:     --input-format-list       list all input formats and exit.
1865:     --optional-configuration-filename
1866:                               an configuration filename that is used if it is available,
1867:                               overriding the configuration-filename option.
1868:     --output-format           output format, default is 'ndf'.
1869:     --output-format-list      list all output formats and exit.
1870:     --prototypes              prototype configuration (filename or code).
1871:     --show-configuration      show the configuration after applying morphology logic and exit.
1872:     --show-library            show the library with specific settings for each morphology.
1873:     --shrinkage               shrinkage correction factor (1 is default)
1874:     --soma-offset             apply soma offset to all compartments (puts the soma at the origin)
1875:     --spine-prototypes        add spines with this prototype.
1876:     --no-use-library          do not use the library with specific settings for each morphology.
1877:     --verbose                 set verbosity level.
1878:     --yaml                    yaml output instead of ndf.
1879: ";
1880: 
1881:         exit 0;
1882:     }
1883: 
1884:     # figure out the cell name
1885: 
1886:     if ($ARGV[0])
1887:     {
1888:         $cellname = $ARGV[0] ;
1889: 
1890:         if (0 && $cellname =~ /\.ndf$/i)
1891:         {
1892:             $source_type = 'neurospaces description format';
1893: 
1894:             $cellname =~ s/\.ndf$//i;
1895:         }
1896:         elsif ($cellname =~ /\.p$/i)
1897:         {
1898:             $source_type = 'genesis morphology';
1899: 
1900:             $cellname =~ s/\.p$//i;
1901:         }
1902:         elsif ($cellname =~ /\.swc$/i)
1903:         {
1904:             $source_type = 'swc morphology';
1905: 
1906:             $cellname =~ s/\.swc$//i;
1907:         }
1908:         else
1909:         {
1910:             die "$0: *** Error: unknown filename extension for file ($cellname)";
1911:         }
1912:     }
1913:     else
1914:     {
1915:         #! from stdin, although that is not really supported anymore
1916: 
1917:         $cellname = 'noname';
1918:     }
1919: 
1920:     $cellname =~ s(.*/)();
1921: 
1922:     $cellname =~ s(\.)(_)g;
1923:     $cellname =~ s(\-)(_)g;
1924: 
1925:     # if configuration filename
1926: 
1927:     if (defined $option_configuration_filename)
1928:     {
1929:         # read the configuration from a filename
1930: 
1931:         eval
1932:         {
1933:             $configuration = LoadFile($option_configuration_filename);
1934:         };
1935: 
1936:         if (!defined $configuration
1937:             || $@)
1938:         {
1939:             die "$0: *** Error: cannot read configuration file $option_configuration_filename ($@), bailing out";
1940:         }
1941: 
1942:     }
1943: 
1944:     # if optional configuration filename
1945: 
1946:     if (defined $option_optional_configuration_filename)
1947:     {
1948:         # read the configuration from a filename
1949: 
1950:         my $optional_configuration;
1951: 
1952:         eval
1953:         {
1954:             $optional_configuration = LoadFile($option_optional_configuration_filename);
1955:         };
1956: 
1957:         if (!defined $optional_configuration
1958:             || $@
1959:             and $option_verbose)
1960:         {
1961:             print "$0: *** Message: cannot read optional configuration file $option_optional_configuration_filename ($@)";
1962:         }
1963: 
1964:         if (defined $optional_configuration)
1965:         {
1966:             $configuration = $optional_configuration;
1967:         }
1968:     }
1969: 
1970:     # we have a cell name, which can be mapped to library specific settings
1971: 
1972:     # if need to use the library
1973: 
1974:     if (!$option_no_use_library)
1975:     {
1976:         # if there is an entry in the library for this cell
1977: 
1978:         if (exists $configuration->{library}->{$cellname})
1979:         {
1980:             # overwrite the configuration that will be applied, with specifics for this morphology
1981: 
1982:             Data::merge($configuration, $configuration->{library}->{$cellname}, { arrays => { overwrite => 1, }, }, );
1983:         }
1984:     }
1985: 
1986:     # correct the configuration for the command line settings
1987: 
1988:     if (defined $option_shrinkage)
1989:     {
1990:         if (!$option_force_library)
1991:         {
1992:             $configuration->{options}->{histology}->{shrinkage} = $option_shrinkage;
1993:         }
1994:         else
1995:         {
1996:             print STDERR "Ignoring shrinkage option of $option_shrinkage, using library value (if any)\n";
1997:         }
1998:     }
1999: 
2000:     if (defined $option_soma_offset
2001:         && $option_soma_offset ne 1)
2002:     {
2003:         if (!$option_force_library)
2004:         {
2005:             $configuration->{options}->{relocation}->{soma_offset} = $option_soma_offset;
2006:         }
2007:         else
2008:         {
2009:             print STDERR "Ignoring soma_offset option, using library value (if any)\n";
2010:         }
2011:     }
2012: 
2013:     if (@$option_spine_prototypes)
2014:     {
2015:         if (!$option_force_library)
2016:         {
2017:             $configuration->{prototypes}->{spine_prototypes} = $option_spine_prototypes;
2018: 
2019:             if (!$configuration->{algorithms}->{spines})
2020:             {
2021:                 use YAML;
2022: 
2023:                 $configuration->{algorithms}->{spines}
2024:                     = YAML::Load('---
2025: fDendrDiaMax: 3.18
2026: fDendrDiaMin: 0.00
2027: fSpineDensity: 13.0
2028: fSpineFrequency: 1.0
2029: ');
2030:             }
2031:         }
2032:         else
2033:         {
2034:             print STDERR "Ignoring spine prototypes, using library value (if any)\n";
2035:         }
2036:     }
2037: 
2038:     # reconfigure: put prototypes in dia order, soma must be at last index
2039: 
2040:     my $prototype_configuration;
2041: 
2042: #     if (defined $option_prototype_configuration)
2043: #     {
2044: #       $prototype_configuration = do $option_prototype_configuration;
2045: 
2046: #       if (!defined $prototype_configuration)
2047: #       {
2048: #           die "$0: *** Error: Prototype configuration not found";
2049: #       }
2050: #     }
2051: #     else
2052:     {
2053:         $prototype_configuration = $configuration->{prototypes};
2054:     }
2055: 
2056:     if (exists $prototype_configuration->{parameter_2_prototype}
2057:         && exists $prototype_configuration->{parameter_2_prototype}->[0]->{dia})
2058:     {
2059:         $prototype_configuration->{parameter_2_prototype}
2060:             = [
2061:                sort
2062:                {
2063:                    if (exists $a->{dia}
2064:                        && exists $b->{dia})
2065:                    {
2066:                        $a->{dia} <=> $b->{dia}
2067:                    }
2068: #                  elsif (exists $a->{tag}
2069: #                         && exists $b->{tag})
2070: #                  {
2071: #                      $a->{tag} <=> $b->{tag}
2072: #                  }
2073:                    else
2074:                    {
2075:                        die "$0: *** Error: the prototype_configuration does not use dia and tag in a consistent way (must use exactly one of them)";
2076:                    }
2077:                }
2078:                @{ $prototype_configuration->{parameter_2_prototype} },
2079:               ];
2080:     }
2081: 
2082:     # process aliasses to a structured format
2083: 
2084:     my $aliasses = $prototype_configuration->{aliasses} || [];
2085: 
2086:     foreach my $alias (sort @$aliasses)
2087:     {
2088:         if ($alias =~ m/^(.*?)::(.*)$/)
2089:         {
2090:             my $filename = "$1";
2091: 
2092:             my $modelname = "$2";
2093: 
2094:             if (defined $converted_aliasses->{$modelname})
2095:             {
2096:                 die "$0: multiple use of alias $modelname";
2097:             }
2098: 
2099:             $converted_aliasses->{$modelname} = $filename;
2100:         }
2101:         else
2102:         {
2103:             die "$0: *** Error: Illegal alias specification ($alias)";
2104:         }
2105:     }
2106: 
2107: #     $prototype_configuration->{aliasses} = $converted_aliasses;
2108: 
2109:     # check if the prototype configuration is consistent
2110: 
2111:     foreach my $relation (@{ $prototype_configuration->{parameter_2_prototype} || [] })
2112:     {
2113:         my $prototype = $relation->{prototype};
2114: 
2115:         if (!defined $prototype)
2116:         {
2117:             die "$0: undefined prototype in the parameter_2_prototype section of the configuration";
2118:         }
2119: 
2120:         if (!defined $converted_aliasses->{$prototype})
2121:         {
2122:             die "$0: prototype $prototype used, but not in the aliasses section, there is no file associated with this prototype";
2123:         }
2124:     }
2125: 
2126:     # if the user asked for the configuration for this morphology
2127: 
2128:     if ($option_show_configuration)
2129:     {
2130:         use YAML;
2131: 
2132:         print Dump($configuration);
2133: 
2134:         exit 0;
2135:     }
2136: 
2137:     #t do some sanity checks on the configuration
2138: 
2139: }
2140: 
2141: 
2142: main();
2143: 
2144: 
2145: